git.iko.soy/stackage
on master help sign in
Merge branch 'master' into ghc7.10

Conflicts: build-constraints.yaml

commit4e5ba05a276eca9ee22fad04bddeacd19987b72e authorMichael Snoyman <michael@snoyman.com> dateWed 18 Mar 2015, 15:23 (12 years ago) parent46f95d8d0138fa
14 files changed+770−196
compare with master
unifiedsplit
ChangeLog.md+8 Dockerfile+2−2 Stackage/BuildConstraints.hs+1−1 Stackage/CompleteBuild.hs+82−40 Stackage/GhcPkg.hs+104 Stackage/InstallBuild.hs+4 Stackage/PerformBuild.hs+151−48 Stackage/Prelude.hs+13 Stackage/ServerBundle.hs+165−8 Stackage/Upload.hs+63−70 app/stackage.hs+55−2 build-constraints.yaml+95−23 debian-bootstrap.sh+20−1 stackage.cabal+7−1
ChangeLog.md+8
@@ -1,3 +1,11 @@
1+## 0.6.1
2+
3+* Switch to V2 upload by default
4+
5+## 0.6.0
6+
7+* Upload bundle V2 stuff
8+
19## 0.5.2
210
311* Upload LTS to Hackage with the name LTSHaskell
Dockerfile+2−2
@@ -14,9 +14,9 @@ ADD debian-bootstrap.sh /tmp/debian-bootstrap.sh
1414RUN DEBIAN_FRONTEND=noninteractive bash /tmp/debian-bootstrap.sh
1515RUN rm /tmp/debian-bootstrap.sh
1616
17−RUN DEBIAN_FRONTEND=noninteractive apt-get install -y cabal-install-1.20 ghc-7.8.4
17+RUN DEBIAN_FRONTEND=noninteractive apt-get install -y cabal-install-1.20 ghc-7.8.4 alex-3.1.3 happy-1.19.4
1818
19−ENV PATH /home/stackage/.cabal/bin:/usr/local/sbin:/usr/local/bin:/opt/ghc/7.8.4/bin:/opt/cabal/1.20/bin:/usr/sbin:/usr/bin:/sbin:/bin
19+ENV PATH /home/stackage/.cabal/bin:/usr/local/sbin:/usr/local/bin:/opt/ghc/7.8.4/bin:/opt/cabal/1.20/bin:/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:/usr/sbin:/usr/bin:/sbin:/bin
2020
2121RUN cabal update
2222ADD . /tmp/stackage
Stackage/BuildConstraints.hs+1−1
@@ -120,7 +120,7 @@ instance FromJSON PackageConstraints where
120120 pcBuildBenchmarks <- o .: "build-benchmarks"
121121 pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags"
122122 pcMaintainer <- o .:? "maintainer"
123− pcEnableLibProfile <- fmap (fromMaybe False) (o .:? "library-profiling")
123+ pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling")
124124 return PackageConstraints {..}
125125
126126-- | The proposed plan from the requirements provided by contributors.
Stackage/CompleteBuild.hs+82−40
@@ -8,6 +8,7 @@ module Stackage.CompleteBuild
88 , completeBuild
99 , justCheck
1010 , justUploadNightly
11+ , getStackageAuthToken
1112 ) where
1213
1314import Control.Concurrent (threadDelay)
@@ -33,10 +34,14 @@ import System.IO (BufferMode (LineBuffering), hSetBuffering)
3334-- | Flags passed in from the command line.
3435data BuildFlags = BuildFlags
3536 { bfEnableTests :: !Bool
37+ , bfEnableHaddock :: !Bool
3638 , bfDoUpload :: !Bool
3739 , bfEnableLibProfile :: !Bool
40+ , bfEnableExecDyn :: !Bool
3841 , bfVerbose :: !Bool
3942 , bfSkipCheck :: !Bool
43+ , bfUploadV1 :: !Bool
44+ , bfServer :: !StackageServer
4045 } deriving (Show)
4146
4247data BuildType = Nightly | LTS BumpType
@@ -55,6 +60,8 @@ data Settings = Settings
5560 , setArgs :: Text -> UploadBundle -> UploadBundle
5661 , postBuild :: IO ()
5762 , distroName :: Text -- ^ distro name on Hackage
63+ , snapshotType :: SnapshotType
64+ , bundleDest :: FilePath
5865 }
5966
6067nightlyPlanFile :: Text -- ^ day
@@ -66,7 +73,7 @@ nightlySettings :: Text -- ^ day
6673 -> Settings
6774nightlySettings day plan' = Settings
6875 { planFile = nightlyPlanFile day
69− , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
76+ , buildDir = fpFromText $ "builds/nightly"
7077 , logDir = fpFromText $ "logs/stackage-nightly-" ++ day
7178 , title = \ghcVer -> concat
7279 [ "Stackage Nightly "
@@ -79,6 +86,8 @@ nightlySettings day plan' = Settings
7986 , plan = plan'
8087 , postBuild = return ()
8188 , distroName = "Stackage"
89+ , snapshotType = STNightly
90+ , bundleDest = fpFromText $ "stackage-nightly-" ++ day ++ ".bundle"
8291 }
8392 where
8493 slug' = "nightly-" ++ day
@@ -119,7 +128,7 @@ getSettings man (LTS bumpType) = do
119128
120129 return Settings
121130 { planFile = newfile
122− , buildDir = fpFromText $ "builds/stackage-lts-" ++ tshow new
131+ , buildDir = fpFromText $ "builds/lts"
123132 , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new
124133 , title = \ghcVer -> concat
125134 [ "LTS Haskell "
@@ -140,6 +149,10 @@ getSettings man (LTS bumpType) = do
140149 putStrLn "Pushing to Git repository"
141150 git ["push"]
142151 , distroName = "LTSHaskell"
152+ , snapshotType =
153+ case new of
154+ LTSVer x y -> STLTS x y
155+ , bundleDest = fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle"
143156 }
144157
145158data LTSVer = LTSVer !Int !Int
@@ -203,7 +216,9 @@ getPerformBuild buildFlags Settings {..} = PerformBuild
203216 , pbJobs = 8
204217 , pbGlobalInstall = False
205218 , pbEnableTests = bfEnableTests buildFlags
219+ , pbEnableHaddock = bfEnableHaddock buildFlags
206220 , pbEnableLibProfiling = bfEnableLibProfile buildFlags
221+ , pbEnableExecDyn = bfEnableExecDyn buildFlags
207222 , pbVerbose = bfVerbose buildFlags
208223 , pbAllowNewer = bfSkipCheck buildFlags
209224 }
@@ -227,10 +242,23 @@ completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do
227242 checkBuildPlan plan
228243
229244 putStrLn "Performing build"
230− performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn
245+ let pb = getPerformBuild buildFlags settings
246+ performBuild pb >>= mapM_ putStrLn
247+
248+ putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest
249+ createBundleV2 CreateBundleV2
250+ { cb2Plan = plan
251+ , cb2Type = snapshotType
252+ , cb2DocsDir = pbDocDir pb
253+ , cb2Dest = bundleDest
254+ }
231255
232256 when (bfDoUpload buildFlags) $
233− finallyUpload settings man
257+ finallyUpload
258+ (not $ bfUploadV1 buildFlags)
259+ (bfServer buildFlags)
260+ settings
261+ man
234262
235263justUploadNightly
236264 :: Text -- ^ nightly date
@@ -238,40 +266,63 @@ justUploadNightly
238266justUploadNightly day = do
239267 plan <- decodeFileEither (fpToString $ nightlyPlanFile day)
240268 >>= either throwM return
241− withManager tlsManagerSettings $ finallyUpload $ nightlySettings day plan
269+ withManager tlsManagerSettings $ finallyUpload False def $ nightlySettings day plan
270+
271+getStackageAuthToken :: IO Text
272+getStackageAuthToken = do
273+ mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"
274+ case mtoken of
275+ Nothing -> decodeUtf8 <$> readFile "/auth-token"
276+ Just token -> return $ pack token
242277
243278-- | The final part of the complete build process: uploading a bundle,
244279-- docs and a distro to hackage.
245−finallyUpload :: Settings -> Manager -> IO ()
246−finallyUpload settings@Settings{..} man = do
280+finallyUpload :: Bool -- ^ use v2 upload
281+ -> StackageServer
282+ -> Settings -> Manager -> IO ()
283+finallyUpload useV2 server settings@Settings{..} man = do
247284 putStrLn "Uploading bundle to Stackage Server"
248285
249− mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"
250− token <-
251− case mtoken of
252− Nothing -> decodeUtf8 <$> readFile "/auth-token"
253− Just token -> return $ pack token
254−
255− now <- epochTime
256− let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
257− (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
258− { ubContents = serverBundle now (title ghcVer) slug plan
259− , ubAuthToken = token
260− }
261− putStrLn $ "New ident: " ++ unSnapshotIdent ident
262− forM_ mloc $ \loc ->
263− putStrLn $ "Track progress at: " ++ loc
286+ token <- getStackageAuthToken
264287
265− postBuild `catchAny` print
288+ if useV2
289+ then do
290+ res <- flip uploadBundleV2 man UploadBundleV2
291+ { ub2Server = server
292+ , ub2AuthToken = token
293+ , ub2Bundle = bundleDest
294+ }
295+ putStrLn $ "New snapshot available at: " ++ res
296+ else do
297+ now <- epochTime
298+ let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
299+ (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
300+ { ubContents = serverBundle now (title ghcVer) slug plan
301+ , ubAuthToken = token
302+ }
303+ putStrLn $ "New ident: " ++ unSnapshotIdent ident
304+ forM_ mloc $ \loc ->
305+ putStrLn $ "Track progress at: " ++ loc
306+
307+ putStrLn "Uploading docs to Stackage Server"
308+ res1 <- tryAny $ uploadDocs UploadDocs
309+ { udServer = def
310+ , udAuthToken = token
311+ , udDocs = pbDocDir pb
312+ , udSnapshot = ident
313+ } man
314+ putStrLn $ "Doc upload response: " ++ tshow res1
315+
316+ putStrLn "Uploading doc map"
317+ tryAny (uploadDocMap UploadDocMap
318+ { udmServer = def
319+ , udmAuthToken = token
320+ , udmSnapshot = ident
321+ , udmDocDir = pbDocDir pb
322+ , udmPlan = plan
323+ } man) >>= print
266324
267− putStrLn "Uploading docs to Stackage Server"
268− res1 <- uploadDocs UploadDocs
269− { udServer = def
270− , udAuthToken = token
271− , udDocs = pbDocDir pb
272− , udSnapshot = ident
273− } man
274− putStrLn $ "Doc upload response: " ++ tshow res1
325+ postBuild `catchAny` print
275326
276327 ecreds <- tryIO $ readFile "/hackage-creds"
277328 case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
@@ -280,14 +331,5 @@ finallyUpload settings@Settings{..} man = do
280331 res2 <- uploadHackageDistroNamed distroName plan username password man
281332 putStrLn $ "Distro upload response: " ++ tshow res2
282333 _ -> putStrLn "No creds found, skipping Hackage distro upload"
283−
284− putStrLn "Uploading doc map"
285− uploadDocMap UploadDocMap
286− { udmServer = def
287− , udmAuthToken = token
288− , udmSnapshot = ident
289− , udmDocDir = pbDocDir pb
290− , udmPlan = plan
291− } man >>= print
292334 where
293335 pb = getPerformBuild (error "finallyUpload.buildFlags") settings
Stackage/GhcPkg.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+-- | General commands related to ghc-pkg.
4+
5+module Stackage.GhcPkg
6+ ( setupPackageDatabase
7+ ) where
8+
9+import Data.Conduit
10+import qualified Data.Conduit.List as CL
11+import Data.Conduit.Process
12+import qualified Data.Conduit.Text as CT
13+import Data.Maybe
14+import Data.Text (Text)
15+import qualified Data.Text as T
16+import Distribution.Compat.ReadP
17+import Distribution.Package
18+import Distribution.Text (parse)
19+import Filesystem.Path.CurrentOS (FilePath)
20+import qualified Filesystem.Path.CurrentOS as FP
21+import Data.Map (Map)
22+import Data.Version (Version)
23+import Stackage.Prelude
24+import Filesystem (removeTree)
25+
26+setupPackageDatabase
27+ :: Maybe FilePath -- ^ database location, Nothing if using global DB
28+ -> FilePath -- ^ documentation root
29+ -> (ByteString -> IO ()) -- ^ logging
30+ -> Map PackageName Version -- ^ packages and versions to be installed
31+ -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package
32+ -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup
33+setupPackageDatabase mdb docDir log' toInstall onUnregister = do
34+ registered1 <- getRegisteredPackages flags
35+ forM_ registered1 $ \pi@(PackageIdentifier name version) ->
36+ case lookup name toInstall of
37+ Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi
38+ _ -> return ()
39+ broken <- getBrokenPackages flags
40+ forM_ broken $ unregisterPackage log' onUnregister docDir flags
41+ foldMap (\(PackageIdentifier name _) -> singletonSet name)
42+ <$> getRegisteredPackages flags
43+ where
44+ flags = ghcPkgFlags mdb
45+
46+ghcPkgFlags :: Maybe FilePath -> [String]
47+ghcPkgFlags mdb =
48+ "--no-user-package-db" :
49+ case mdb of
50+ Nothing -> ["--global"]
51+ Just fp -> ["--package-db=" ++ fpToString fp]
52+
53+-- | Get broken packages.
54+getBrokenPackages :: [String] -> IO [PackageIdentifier]
55+getBrokenPackages flags = do
56+ (_,ps) <- sourceProcessWithConsumer
57+ (proc
58+ "ghc-pkg"
59+ ("check" : "--simple-output" : flags))
60+ (CT.decodeUtf8 $= CT.lines $= CL.consume)
61+ return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))
62+
63+-- | Get available packages.
64+getRegisteredPackages :: [String] -> IO [PackageIdentifier]
65+getRegisteredPackages flags = do
66+ (_,ps) <- sourceProcessWithConsumer
67+ (proc
68+ "ghc-pkg"
69+ ("list" : "--simple-output" : flags))
70+ (CT.decodeUtf8 $= CT.lines $= CL.consume)
71+ return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))
72+
73+-- | Parse a package identifier: foo-1.2.3
74+parsePackageIdent :: Text -> Maybe PackageIdentifier
75+parsePackageIdent = fmap fst .
76+ listToMaybe .
77+ filter (null . snd) .
78+ readP_to_S parse . T.unpack
79+
80+-- | Unregister a package.
81+unregisterPackage :: (ByteString -> IO ()) -- ^ log func
82+ -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package
83+ -> FilePath -- ^ doc directory
84+ -> [String] -> PackageIdentifier -> IO ()
85+unregisterPackage log' onUnregister docDir flags ident@(PackageIdentifier name _) = do
86+ log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n"
87+ onUnregister ident
88+
89+ -- Delete libraries
90+ sourceProcessWithConsumer
91+ (proc "ghc-pkg" ("describe" : flags ++ [unpack $ display ident]))
92+ (CT.decodeUtf8
93+ $= CT.lines
94+ $= CL.mapMaybe parseLibraryDir
95+ $= CL.mapM_ (void . tryIO . removeTree))
96+
97+ void (readProcessWithExitCode
98+ "ghc-pkg"
99+ ("unregister": flags ++ ["--force", unpack $ display name])
100+ "")
101+
102+ void $ tryIO $ removeTree $ docDir </> fpFromText (display ident)
103+ where
104+ parseLibraryDir = fmap fpFromText . stripPrefix "library-dirs: "
Stackage/InstallBuild.hs+4
@@ -28,7 +28,9 @@ data InstallFlags = InstallFlags
2828 , ifJobs :: !Int
2929 , ifGlobalInstall :: !Bool
3030 , ifEnableTests :: !Bool
31+ , ifEnableHaddock :: !Bool
3132 , ifEnableLibProfiling :: !Bool
33+ , ifEnableExecDyn :: !Bool
3234 , ifVerbose :: !Bool
3335 , ifSkipCheck :: !Bool
3436 } deriving (Show)
@@ -48,7 +50,9 @@ getPerformBuild plan InstallFlags{..} =
4850 , pbJobs = ifJobs
4951 , pbGlobalInstall = ifGlobalInstall
5052 , pbEnableTests = ifEnableTests
53+ , pbEnableHaddock = ifEnableHaddock
5154 , pbEnableLibProfiling = ifEnableLibProfiling
55+ , pbEnableExecDyn = ifEnableExecDyn
5256 , pbVerbose = ifVerbose
5357 , pbAllowNewer = ifSkipCheck
5458 }
Stackage/PerformBuild.hs+151−48
@@ -19,17 +19,18 @@ import qualified Data.Map as Map
1919import Data.NonNull (fromNullable)
2020import Filesystem (canonicalizePath, createTree,
2121 getWorkingDirectory, isDirectory,
22− removeTree, rename)
22+ removeTree, rename, isFile, removeFile)
2323import Filesystem.Path (parent)
2424import qualified Filesystem.Path as F
2525import Stackage.BuildConstraints
2626import Stackage.BuildPlan
27+import Stackage.GhcPkg
2728import Stackage.PackageDescription
2829import Stackage.Prelude hiding (pi)
2930import System.Directory (findExecutable)
3031import System.Environment (getEnvironment)
3132import System.IO (IOMode (WriteMode),
32− withBinaryFile)
33+ openBinaryFile)
3334import System.IO.Temp (withSystemTempDirectory)
3435
3536data BuildException = BuildException (Map PackageName BuildFailure) [Text]
@@ -62,7 +63,9 @@ data PerformBuild = PerformBuild
6263 , pbGlobalInstall :: Bool
6364 -- ^ Register packages in the global database
6465 , pbEnableTests :: Bool
66+ , pbEnableHaddock :: Bool
6567 , pbEnableLibProfiling :: Bool
68+ , pbEnableExecDyn :: Bool
6669 , pbVerbose :: Bool
6770 , pbAllowNewer :: Bool
6871 -- ^ Pass --allow-newer to cabal configure
@@ -89,7 +92,7 @@ waitForDeps toolMap packageMap activeComps bp pi action = do
8992 Nothing
9093 | isCoreExe exe -> return ()
9194 -- https://github.com/jgm/zip-archive/issues/23
92− -- | otherwise -> throwSTM $ ToolMissing exe
95+ -- - | otherwise -> throwSTM $ ToolMissing exe
9396 | otherwise -> return ()
9497 Just packages -> ofoldl1' (<|>) packages
9598 action
@@ -133,6 +136,10 @@ pbLibDir pb = pbInstallDest pb </> "lib"
133136pbDataDir pb = pbInstallDest pb </> "share"
134137pbDocDir pb = pbInstallDest pb </> "doc"
135138
139+-- | Directory keeping previous result info
140+pbPrevResDir :: PerformBuild -> FilePath
141+pbPrevResDir pb = pbInstallDest pb </> "prevres"
142+
136143performBuild :: PerformBuild -> IO [Text]
137144performBuild pb = do
138145 cwd <- getWorkingDirectory
@@ -160,12 +167,13 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
160167 $ \ClosedStream Inherited Inherited -> return ()
161168
162169 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
163− mapM_ removeTree' [pbInstallDest, pbLogDir]
170+ removeTree' pbLogDir
164171
165− forM_ (pbDatabase pb) $ \db -> do
166− createTree $ parent db
167− withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
168− $ \ClosedStream Inherited Inherited -> return ()
172+ forM_ (pbDatabase pb) $ \db ->
173+ unlessM (isFile $ db </> "package.cache") $ do
174+ createTree $ parent db
175+ withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
176+ $ \ClosedStream Inherited Inherited -> return ()
169177 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
170178 copyBuiltInHaddocks (pbDocDir pb)
171179 pbLog $ encodeUtf8 "Finished copying built-in Haddocks\n"
@@ -186,7 +194,15 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
186194 env <- getEnvironment
187195 haddockFiles <- newTVarIO mempty
188196
189− forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
197+ registeredPackages <- setupPackageDatabase
198+ (pbDatabase pb)
199+ (pbDocDir pb)
200+ pbLog
201+ (ppVersion <$> bpPackages pbPlan)
202+ (deletePreviousResults pb)
203+
204+ forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages
205+ SingleBuild
190206 { sbSem = sem
191207 , sbErrsVar = errsVar
192208 , sbWarningsVar = warningsVar
@@ -248,8 +264,10 @@ data SingleBuild = SingleBuild
248264 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
249265 }
250266
251−singleBuild :: PerformBuild -> SingleBuild -> IO ()
252−singleBuild pb@PerformBuild {..} SingleBuild {..} =
267+singleBuild :: PerformBuild
268+ -> Set PackageName -- ^ registered packages
269+ -> SingleBuild -> IO ()
270+singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
253271 withCounter sbActive
254272 $ handle updateErrs
255273 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
@@ -261,22 +279,25 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
261279 let wfd comps =
262280 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
263281 . withTSem sbSem
264− wfd libComps buildLibrary
282+ withUnpacked <- wfd libComps buildLibrary
265283
266− wfd testComps runTests
284+ wfd testComps (runTests withUnpacked)
267285
268− name = display $ piName sbPackageInfo
286+ pname = piName sbPackageInfo
287+ pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
288+ name = display pname
269289 namever = concat
270290 [ name
271291 , "-"
272292 , display $ ppVersion $ piPlan sbPackageInfo
273293 ]
274294
275− runIn wdir outH cmd args =
276− withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
295+ runIn wdir getOutH cmd args = do
296+ outH <- getOutH
297+ withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
277298 (return () :: IO ())
278299 where
279− cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
300+ cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args))
280301 { cwd = Just $ fpToString wdir
281302 , std_out = UseHandle outH
282303 , std_err = UseHandle outH
@@ -302,8 +323,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
302323 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
303324
304325 wf fp inner' = do
305− createTree $ parent fp
306− withBinaryFile (fpToString fp) WriteMode inner'
326+ ref <- newIORef Nothing
327+ let cleanup = do
328+ mh <- readIORef ref
329+ forM_ mh hClose
330+ getH = do
331+ mh <- readIORef ref
332+ case mh of
333+ Just h -> return h
334+ Nothing -> mask_ $ do
335+ createTree $ parent fp
336+ h <- openBinaryFile (fpToString fp) WriteMode
337+ writeIORef ref $ Just h
338+ return h
339+
340+ inner' getH `finally` cleanup
307341
308342 configArgs = ($ []) $ execWriter $ do
309343 when pbAllowNewer $ tell' "--allow-newer"
@@ -317,6 +351,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
317351 tell' $ "--flags=" ++ flags
318352 when (pbEnableLibProfiling && pcEnableLibProfile) $
319353 tell' "--enable-library-profiling"
354+ when pbEnableExecDyn $ tell' "--enable-executable-dynamic"
320355 where
321356 tell' x = tell (x:)
322357
@@ -330,22 +365,40 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
330365
331366 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
332367
333− buildLibrary = wf libOut $ \outH -> do
368+ buildLibrary = wf libOut $ \getOutH -> do
334369 let run a b = do when pbVerbose $ log' (unwords (a : b))
335− runChild outH a b
336− log' $ "Unpacking " ++ namever
337− runParent outH "cabal" ["unpack", namever]
338−
339− log' $ "Configuring " ++ namever
340− run "cabal" $ "configure" : configArgs
341−
342− log' $ "Building " ++ namever
343− run "cabal" ["build"]
344−
345− log' $ "Copying/registering " ++ namever
346− run "cabal" ["copy"]
347− withMVar sbRegisterMutex $ const $
348− run "cabal" ["register"]
370+ runChild getOutH a b
371+
372+ isUnpacked <- newIORef False
373+ let withUnpacked inner = do
374+ unlessM (readIORef isUnpacked) $ do
375+ log' $ "Unpacking " ++ namever
376+ runParent getOutH "cabal" ["unpack", namever]
377+ writeIORef isUnpacked True
378+ inner
379+
380+ isConfiged <- newIORef False
381+ let withConfiged inner = withUnpacked $ do
382+ unlessM (readIORef isConfiged) $ do
383+ log' $ "Configuring " ++ namever
384+ run "cabal" $ "configure" : configArgs
385+ writeIORef isConfiged True
386+ inner
387+
388+ prevBuildResult <- getPreviousResult pb Build pident
389+ unless (prevBuildResult == PRSuccess) $ withConfiged $ do
390+ assert (pname `notMember` registeredPackages) $ do
391+ deletePreviousResults pb pident
392+
393+ log' $ "Building " ++ namever
394+ run "cabal" ["build"]
395+
396+ log' $ "Copying/registering " ++ namever
397+ run "cabal" ["copy"]
398+ withMVar sbRegisterMutex $ const $
399+ run "cabal" ["register"]
400+
401+ savePreviousResult pb Build pident True
349402
350403 -- Even if the tests later fail, we can allow other libraries to build
351404 -- on top of our successful results
@@ -355,7 +408,11 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
355408 -- dependency's haddocks before this finishes
356409 atomically $ putTMVar (piResult sbPackageInfo) True
357410
358− when (pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
411+ prevHaddockResult <- getPreviousResult pb Haddock pident
412+ let needHaddock = pbEnableHaddock
413+ && checkPrevResult prevHaddockResult pcHaddocks
414+ && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
415+ when needHaddock $ withConfiged $ do
359416 log' $ "Haddocks " ++ namever
360417 hfs <- readTVarIO sbHaddockFiles
361418 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
@@ -389,15 +446,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
389446 $ modifyTVar sbHaddockFiles
390447 $ insertMap namever newPath
391448
449+ savePreviousResult pb Haddock pident $ either (const False) (const True) eres
392450 case (eres, pcHaddocks) of
393451 (Left e, ExpectSuccess) -> throwM e
394452 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
395453 _ -> return ()
396454
397− runTests = wf testOut $ \outH -> do
398− let run = runChild outH
455+ return withUnpacked
456+
457+ runTests withUnpacked = wf testOut $ \getOutH -> do
458+ let run = runChild getOutH
399459
400− when (pbEnableTests && pcTests /= Don'tBuild) $ do
460+ prevTestResult <- getPreviousResult pb Test pident
461+ let needTest = pbEnableTests
462+ && checkPrevResult prevTestResult pcTests
463+ when needTest $ withUnpacked $ do
401464 log' $ "Test configure " ++ namever
402465 run "cabal" $ "configure" : "--enable-tests" : configArgs
403466
@@ -408,6 +471,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
408471 log' $ "Test run " ++ namever
409472 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
410473
474+ savePreviousResult pb Test pident $ either (const False) (const True) eres
411475 case (eres, pcTests) of
412476 (Left e, ExpectSuccess) -> throwM e
413477 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
@@ -434,16 +498,6 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
434498renameOrCopy :: FilePath -> FilePath -> IO ()
435499renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
436500
437−copyDir :: FilePath -> FilePath -> IO ()
438−copyDir src dest =
439− runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
440− where
441− src' = src </> ""
442− go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
443− let dest' = dest </> suffix
444− liftIO $ createTree $ parent dest'
445− sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
446−
447501copyBuiltInHaddocks :: FilePath -> IO ()
448502copyBuiltInHaddocks docdir = do
449503 mghc <- findExecutable "ghc"
@@ -453,3 +507,52 @@ copyBuiltInHaddocks docdir = do
453507 src <- canonicalizePath
454508 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
455509 copyDir src docdir
510+
511+------------- Previous results
512+
513+-- | The previous actions that can be run
514+data ResultType = Build | Haddock | Test
515+ deriving (Show, Enum, Eq, Ord, Bounded, Read)
516+
517+-- | The result generated on a previous run
518+data PrevResult = PRNoResult | PRSuccess | PRFailure
519+ deriving (Show, Enum, Eq, Ord, Bounded, Read)
520+
521+-- | Check if we should rerun based on a PrevResult and the expected status
522+checkPrevResult :: PrevResult -> TestState -> Bool
523+checkPrevResult _ Don'tBuild = False
524+checkPrevResult PRNoResult _ = True
525+checkPrevResult PRSuccess _ = False
526+checkPrevResult PRFailure ExpectSuccess = True
527+checkPrevResult PRFailure _ = False
528+
529+withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
530+withPRPath pb rt ident inner = do
531+ createTree $ parent fp
532+ inner fp
533+ where
534+ fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)
535+
536+successBS, failureBS :: ByteString
537+successBS = "success"
538+failureBS = "failure"
539+
540+getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
541+getPreviousResult w x y = withPRPath w x y $ \fp -> do
542+ eres <- tryIO $ readFile fp
543+ return $ case eres of
544+ Right bs
545+ | bs == successBS -> PRSuccess
546+ | bs == failureBS -> PRFailure
547+ _ -> PRNoResult
548+
549+savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
550+savePreviousResult pb rt ident res =
551+ withPRPath pb rt ident $ \fp -> writeFile fp $
552+ if res then successBS else failureBS
553+
554+deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
555+deletePreviousResults pb name =
556+ forM_ [minBound..maxBound] $ \rt ->
557+ withPRPath pb rt name $ \fp ->
558+ void $ tryIO $ removeFile fp
Stackage/Prelude.hs+13
@@ -20,6 +20,9 @@ import Distribution.Version as X (Version (..),
2020 VersionRange)
2121import Distribution.Version as X (withinRange)
2222import qualified Distribution.Version as C
23+import Filesystem (createTree)
24+import Filesystem.Path (parent)
25+import qualified Filesystem.Path as F
2326
2427unPackageName :: PackageName -> Text
2528unPackageName (PackageName str) = pack str
@@ -101,3 +104,13 @@ topologicalSort toFinal toDeps =
101104data TopologicalSortException key = NoEmptyDeps (Map key (Set key))
102105 deriving (Show, Typeable)
103106instance (Show key, Typeable key) => Exception (TopologicalSortException key)
107+
108+copyDir :: FilePath -> FilePath -> IO ()
109+copyDir src dest =
110+ runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
111+ where
112+ src' = src </> ""
113+ go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
114+ let dest' = dest </> suffix
115+ liftIO $ createTree $ parent dest'
116+ sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
Stackage/ServerBundle.hs+165−8
@@ -7,21 +7,31 @@ module Stackage.ServerBundle
77 , epochTime
88 , bpAllPackages
99 , docsListing
10+ , createBundleV2
11+ , CreateBundleV2 (..)
12+ , SnapshotType (..)
13+ , writeIndexStyle
14+ , DocMap
15+ , PackageDocs (..)
1016 ) where
1117
1218import qualified Codec.Archive.Tar as Tar
1319import qualified Codec.Archive.Tar.Entry as Tar
1420import qualified Codec.Compression.GZip as GZip
1521import qualified Data.Map as M
22+import Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject)
23+import System.IO.Temp (withTempDirectory)
1624import qualified Data.Yaml as Y
17−import Filesystem (isFile)
25+import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath)
1826import Foreign.C.Types (CTime (CTime))
1927import Stackage.BuildConstraints
2028import Stackage.BuildPlan
2129import Stackage.Prelude
30+import System.IO.Temp (withTempDirectory)
2231import qualified System.PosixCompat.Time as PC
2332import qualified Text.XML as X
2433import Text.XML.Cursor
34+import System.PosixCompat.Files (createSymbolicLink)
2535
2636-- | Get current time
2737epochTime :: IO Tar.EpochTime
@@ -73,13 +83,30 @@ serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
7383 map (\(PackageName name) -> name)
7484 (M.keys $ siCorePackages bpSystemInfo)
7585
86+-- | Package name is key
87+type DocMap = Map Text PackageDocs
88+data PackageDocs = PackageDocs
89+ { pdVersion :: Text
90+ , pdModules :: Map Text [Text]
91+ -- ^ module name, path
92+ }
93+instance ToJSON PackageDocs where
94+ toJSON PackageDocs {..} = object
95+ [ "version" .= pdVersion
96+ , "modules" .= pdModules
97+ ]
98+instance FromJSON PackageDocs where
99+ parseJSON = withObject "PackageDocs" $ \o -> PackageDocs
100+ <$> o .: "version"
101+ <*> o .: "modules"
102+
76103docsListing :: BuildPlan
77104 -> FilePath -- ^ docs directory
78− -> IO ByteString
105+ -> IO DocMap
79106docsListing bp docsDir =
80− fmap (Y.encode . fold) $ mapM go $ mapToList $ bpAllPackages bp
107+ fmap fold $ mapM go $ mapToList $ bpAllPackages bp
81108 where
82− go :: (PackageName, Version) -> IO (Map Text Y.Value)
109+ go :: (PackageName, Version) -> IO DocMap
83110 go (package, version) = do -- handleAny (const $ return mempty) $ do
84111 let dirname = fpFromText (concat
85112 [ display package
@@ -107,8 +134,138 @@ docsListing bp docsDir =
107134 return $ if e
108135 then asMap $ singletonMap name [fpToText dirname, href]
109136 else mempty
110− return $ singletonMap (display package) $ Y.object
111− [ "version" Y..= display version
112− , "modules" Y..= m
113− ]
137+ return $ singletonMap (display package) $ PackageDocs
138+ { pdVersion = display version
139+ , pdModules = m
140+ }
114141 else return mempty
142+
143+data SnapshotType = STNightly
144+ | STLTS !Int !Int -- ^ major, minor
145+ deriving (Show, Read, Eq, Ord)
146+
147+instance ToJSON SnapshotType where
148+ toJSON STNightly = object
149+ [ "type" .= asText "nightly"
150+ ]
151+ toJSON (STLTS major minor) = object
152+ [ "type" .= asText "lts"
153+ , "major" .= major
154+ , "minor" .= minor
155+ ]
156+instance FromJSON SnapshotType where
157+ parseJSON = withObject "SnapshotType" $ \o -> do
158+ t <- o .: "type"
159+ case asText t of
160+ "nightly" -> return STNightly
161+ "lts" -> STLTS
162+ <$> o .: "major"
163+ <*> o .: "minor"
164+ _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t
165+
166+data CreateBundleV2 = CreateBundleV2
167+ { cb2Plan :: BuildPlan
168+ , cb2Type :: SnapshotType
169+ , cb2DocsDir :: FilePath
170+ , cb2Dest :: FilePath
171+ }
172+
173+-- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc
174+-- map.
175+createBundleV2 :: CreateBundleV2 -> IO ()
176+createBundleV2 CreateBundleV2 {..} = do
177+ docsDir <- canonicalizePath cb2DocsDir
178+ docMap <- docsListing cb2Plan cb2DocsDir
179+
180+ Y.encodeFile (fpToString $ docsDir </> "build-plan.yaml") cb2Plan
181+ Y.encodeFile (fpToString $ docsDir </> "build-type.yaml") cb2Type
182+ Y.encodeFile (fpToString $ docsDir </> "docs-map.yaml") docMap
183+ void $ writeIndexStyle Nothing cb2DocsDir
184+
185+ currentDir <- getWorkingDirectory
186+ files <- listDirectory docsDir
187+
188+ let args = "cfJ"
189+ : fpToString (currentDir </> cb2Dest)
190+ : "--dereference"
191+ : map (fpToString . filename) files
192+ cp = (proc "tar" args) { cwd = Just $ fpToString docsDir }
193+ withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
194+
195+writeIndexStyle :: Maybe Text -- ^ snapshot id
196+ -> FilePath -- ^ docs dir
197+ -> IO [String]
198+writeIndexStyle msnapid dir = do
199+ dirs <- fmap sort
200+ $ runResourceT
201+ $ sourceDirectory dir
202+ $$ filterMC (liftIO . isDirectory)
203+ =$ mapC (fpToString . filename)
204+ =$ sinkList
205+ writeFile (dir </> "index.html") $ mkIndex
206+ (unpack <$> msnapid)
207+ dirs
208+ writeFile (dir </> "style.css") styleCss
209+ return dirs
210+
211+mkIndex :: Maybe String -> [String] -> String
212+mkIndex msnapid dirs = concat
213+ [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
214+ , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
215+ , "<link rel='stylesheet' href='style.css'>"
216+ , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
217+ , "</head>"
218+ , "<body><div class='container'>"
219+ , "<div class='row'><div class='span12 col-md-12'>"
220+ , "<h1>Haddock documentation index</h1>"
221+ , flip foldMap msnapid $ \snapid -> concat
222+ [ "<p class='return'><a href=\"http://www.stackage.org/stackage/"
223+ , snapid
224+ , "\">Return to snapshot</a></p>"
225+ ]
226+ , "<ul>"
227+ , concatMap toLI dirs
228+ , "</ul></div></div></div></body></html>"
229+ ]
230+ where
231+ toLI name = concat
232+ [ "<li><a href='"
233+ , name
234+ , "/index.html'>"
235+ , name
236+ , "</a></li>"
237+ ]
238+
239+styleCss :: String
240+styleCss = concat
241+ [ "@media (min-width: 530px) {"
242+ , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
243+ , "}"
244+ , "@media (min-width: 760px) {"
245+ , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
246+ , "}"
247+ , "ul {"
248+ , " margin-left: 0;"
249+ , " padding-left: 0;"
250+ , " list-style-type: none;"
251+ , "}"
252+ , "body {"
253+ , " background: #f0f0f0;"
254+ , " font-family: 'Lato', sans-serif;"
255+ , " text-shadow: 1px 1px 1px #ffffff;"
256+ , " font-size: 20px;"
257+ , " line-height: 30px;"
258+ , " padding-bottom: 5em;"
259+ , "}"
260+ , "h1 {"
261+ , " font-weight: normal;"
262+ , " color: #06537d;"
263+ , " font-size: 45px;"
264+ , "}"
265+ , ".return a {"
266+ , " color: #06537d;"
267+ , " font-style: italic;"
268+ , "}"
269+ , ".return {"
270+ , " margin-bottom: 1em;"
271+ , "}"]
Stackage/Upload.hs+63−70
@@ -14,17 +14,26 @@ module Stackage.Upload
1414 , uploadHackageDistroNamed
1515 , UploadDocMap (..)
1616 , uploadDocMap
17+ , uploadBundleV2
18+ , UploadBundleV2 (..)
19+ , def
20+ , StackageServer
21+ , unStackageServer
1722 ) where
1823
1924import Control.Monad.Writer.Strict (execWriter, tell)
2025import Data.Default.Class (Default (..))
26+import Data.Function (fix)
2127import Filesystem (isDirectory, isFile)
2228import Network.HTTP.Client
29+import qualified Network.HTTP.Client.Conduit as HCC
2330import Network.HTTP.Client.MultipartFormData
2431import Stackage.BuildPlan (BuildPlan)
2532import Stackage.Prelude
26−import Stackage.ServerBundle (bpAllPackages, docsListing)
33+import Stackage.ServerBundle (bpAllPackages, docsListing, writeIndexStyle)
2734import System.IO.Temp (withSystemTempFile)
35+import qualified System.IO as IO
36+import qualified Data.Yaml as Y
2837
2938newtype StackageServer = StackageServer { unStackageServer :: Text }
3039 deriving (Show, Eq, Ord, Hashable, IsString)
@@ -107,17 +116,7 @@ uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do
107116 where
108117 uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do
109118 hClose h
110− dirs <- fmap sort
111− $ runResourceT
112− $ sourceDirectory fp0
113− $$ filterMC (liftIO . isDirectory)
114− =$ mapC (fpToString . filename)
115− =$ sinkList
116− writeFile (fp0 </> "index.html") $ mkIndex
117− (unpack $ unSnapshotIdent ident)
118− dirs
119− writeFile (fp0 </> "style.css") styleCss
120− -- FIXME write index.html, style.css
119+ dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0
121120 let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)
122121 { cwd = Just $ fpToString fp0
123122 }
@@ -201,7 +200,7 @@ uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString)
201200uploadDocMap UploadDocMap {..} man = do
202201 docmap <- docsListing udmPlan udmDocDir
203202 req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"
204− req2 <- formDataBody (formData docmap) req1
203+ req2 <- formDataBody (formData $ Y.encode docmap) req1
205204 let req3 = req2
206205 { method = "PUT"
207206 , requestHeaders =
@@ -219,61 +218,55 @@ uploadDocMap UploadDocMap {..} man = do
219218 , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap
220219 ]
221220
222−mkIndex :: String -> [String] -> String
223−mkIndex snapid dirs = concat
224− [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
225− , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
226− , "<link rel='stylesheet' href='style.css'>"
227− , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
228− , "</head>"
229− , "<body><div class='container'>"
230− , "<div class='row'><div class='span12 col-md-12'>"
231− , "<h1>Haddock documentation index</h1>"
232− , "<p class='return'><a href=\"http://www.stackage.org/stackage/"
233− , snapid
234− , "\">Return to snapshot</a></p><ul>"
235− , concatMap toLI dirs
236− , "</ul></div></div></div></body></html>"
237− ]
238− where
239− toLI name = concat
240− [ "<li><a href='"
241− , name
242− , "/index.html'>"
243− , name
244− , "</a></li>"
245− ]
221+data UploadBundleV2 = UploadBundleV2
222+ { ub2Server :: StackageServer
223+ , ub2AuthToken :: Text
224+ , ub2Bundle :: FilePath
225+ }
246226
247−styleCss :: String
248−styleCss = concat
249− [ "@media (min-width: 530px) {"
250− , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
251− , "}"
252− , "@media (min-width: 760px) {"
253− , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
254− , "}"
255− , "ul {"
256− , " margin-left: 0;"
257− , " padding-left: 0;"
258− , " list-style-type: none;"
259− , "}"
260− , "body {"
261− , " background: #f0f0f0;"
262− , " font-family: 'Lato', sans-serif;"
263− , " text-shadow: 1px 1px 1px #ffffff;"
264− , " font-size: 20px;"
265− , " line-height: 30px;"
266− , " padding-bottom: 5em;"
267− , "}"
268− , "h1 {"
269− , " font-weight: normal;"
270− , " color: #06537d;"
271− , " font-size: 45px;"
272− , "}"
273− , ".return a {"
274− , " color: #06537d;"
275− , " font-style: italic;"
276− , "}"
277− , ".return {"
278− , " margin-bottom: 1em;"
279− , "}"]
227+uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text
228+uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do
229+ size <- IO.hFileSize h
230+ putStrLn $ "Bundle size: " ++ tshow size
231+ req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"
232+ let req2 = req1
233+ { method = "PUT"
234+ , requestHeaders =
235+ [ ("Authorization", encodeUtf8 ub2AuthToken)
236+ , ("Accept", "application/json")
237+ , ("Content-Type", "application/x-tar")
238+ ]
239+ , requestBody = HCC.requestBodySource (fromIntegral size)
240+ $ sourceHandle h $= printProgress size
241+ }
242+ sink = decodeUtf8C =$ fix (\loop -> do
243+ mx <- peekC
244+ case mx of
245+ Nothing -> error $ "uploadBundleV2: premature end of stream"
246+ Just _ -> do
247+ l <- lineC $ takeCE 4096 =$ foldC
248+ let (cmd, msg') = break (== ':') l
249+ msg = dropWhile (== ' ') $ dropWhile (== ':') msg'
250+ case cmd of
251+ "CONT" -> do
252+ putStrLn msg
253+ loop
254+ "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg
255+ "SUCCESS" -> return msg
256+ _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd
257+ )
258+ withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink
259+ where
260+ printProgress total =
261+ loop 0 0
262+ where
263+ loop sent lastPercent =
264+ await >>= maybe (putStrLn "Upload complete") go
265+ where
266+ go bs = do
267+ yield bs
268+ let sent' = sent + fromIntegral (length bs)
269+ percent = sent' * 100 `div` total
270+ when (percent /= lastPercent)
271+ $ putStrLn $ "Upload progress: " ++ tshow percent ++ "%"
272+ loop sent' percent
app/stackage.hs+55−2
@@ -10,7 +10,11 @@ import Options.Applicative
1010import Filesystem.Path.CurrentOS (decodeString)
1111import Paths_stackage (version)
1212import Stackage.CompleteBuild
13+import Stackage.Upload
1314import Stackage.InstallBuild
15+import Network.HTTP.Client (withManager)
16+import Network.HTTP.Client.TLS (tlsManagerSettings)
17+import qualified Data.Text as T
1418
1519main :: IO ()
1620main =
@@ -62,7 +66,13 @@ main =
6266 installBuild
6367 installFlags
6468 "install"
65− "Install a snapshot from an existing build plan"]
69+ "Install a snapshot from an existing build plan"
70+ , cmnd
71+ uploadv2
72+ uploadv2Flags
73+ "upload2"
74+ "Upload a pre-existing v2 bundle"
75+ ]
6676
6777 cmnd exec parse name desc =
6878 command name $
@@ -77,6 +87,11 @@ main =
7787 (switch
7888 (long "skip-tests" <>
7989 help "Skip build and running the test suites")) <*>
90+ fmap
91+ not
92+ (switch
93+ (long "skip-haddock" <>
94+ help "Skip generating haddock documentation")) <*>
8095 fmap
8196 not
8297 (switch
@@ -85,12 +100,23 @@ main =
85100 switch
86101 (long "enable-library-profiling" <>
87102 help "Enable profiling when building") <*>
103+ switch
104+ (long "enable-executable-dynamic" <>
105+ help "Enable dynamic executables when building") <*>
88106 switch
89107 (long "verbose" <> short 'v' <>
90108 help "Output verbose detail about the build steps") <*>
91109 switch
92110 (long "skip-check" <>
93− help "Skip the check phase, and pass --allow-newer to cabal configure")
111+ help "Skip the check phase, and pass --allow-newer to cabal configure") <*>
112+ switch
113+ (long "upload-v1" <>
114+ help "Use the V1 upload code") <*>
115+ (fmap fromString (strOption
116+ (long "server-url" <>
117+ metavar "SERVER-URL" <>
118+ showDefault <> value (T.unpack $ unStackageServer def) <>
119+ help "Server to upload bundle to")))
94120
95121 nightlyUploadFlags = fromString <$> strArgument
96122 (metavar "DATE" <>
@@ -136,12 +162,39 @@ main =
136162 (switch
137163 (long "skip-tests" <>
138164 help "Skip build and running the test suites")) <*>
165+ fmap
166+ not
167+ (switch
168+ (long "skip-haddock" <>
169+ help "Skip generating haddock documentation")) <*>
139170 switch
140171 (long "enable-library-profiling" <>
141172 help "Enable profiling when building") <*>
173+ switch
174+ (long "enable-executable-dynamic" <>
175+ help "Enable dynamic executables when building") <*>
142176 switch
143177 (long "verbose" <> short 'v' <>
144178 help "Output verbose detail about the build steps") <*>
145179 switch
146180 (long "skip-check" <>
147181 help "Skip the check phase, and pass --allow-newer to cabal configure")
182+
183+ uploadv2 (path, url) = withManager tlsManagerSettings $ \man -> do
184+ token <- getStackageAuthToken
185+ res <- flip uploadBundleV2 man UploadBundleV2
186+ { ub2AuthToken = token
187+ , ub2Server = fromString url
188+ , ub2Bundle = decodeString path
189+ }
190+ putStrLn $ "New URL: " ++ T.unpack res
191+
192+ uploadv2Flags = (,)
193+ <$> (strArgument
194+ (metavar "BUNDLE-PATH" <>
195+ help "Bundle path"))
196+ <*> strOption
197+ (long "server-url" <>
198+ metavar "SERVER-URL" <>
199+ showDefault <> value (T.unpack $ unStackageServer def) <>
200+ help "Server to upload bundle to")
build-constraints.yaml+95−23
@@ -379,6 +379,7 @@ packages:
379379 - pipes
380380 - pipes-parse
381381 - pipes-concurrency
382+ - pipes-safe
382383
383384 "Chris Allen <cma@bitemyapp.com>":
384385 - bloodhound
@@ -390,9 +391,12 @@ packages:
390391 - fay-jquery
391392 - fay-text
392393 - fay-uri
393− - fclabels
394394 - snaplet-fay
395395
396+ "Sebastiaan Visser <haskell@fvisser.nl>":
397+ - clay
398+ - fclabels
399+
396400 "Rodrigo Setti <rodrigosetti@gmail.com>":
397401 - messagepack
398402 - messagepack-rpc
@@ -473,7 +477,8 @@ packages:
473477 - openpgp-asciiarmor
474478 - MusicBrainz
475479 - DAV
476− - hopenpgp-tools
480+ # https://github.com/fpco/stackage/issues/463
481+ #- hopenpgp-tools
477482
478483 # https://github.com/fpco/stackage/issues/160
479484 "Ketil Malde":
@@ -503,9 +508,9 @@ packages:
503508 - code-builder
504509 - fay-builder
505510 - generic-aeson
511+ - generic-xmlpickler
506512 - hxt-pickle-utils
507513 - imagesize-conduit
508− - imagesize-conduit
509514 - json-schema
510515 - multipart
511516 - regular-xmlpickler
@@ -518,8 +523,6 @@ packages:
518523 - rest-types
519524 - rest-wai
520525 - tostring
521− - tostring
522− - uri-encode
523526 - uri-encode
524527
525528 "Simon Michael <simon@joyful.com>":
@@ -529,7 +532,10 @@ packages:
529532 - io-manager
530533
531534 "Dimitri Sabadie <dimitri.sabadie@gmail.com":
535+ # https://github.com/fpco/stackage/pull/461#issuecomment-76914158
536+ # - al
532537 - monad-journal
538+ - smoothie
533539
534540 "Thomas Schilling <nominolo@googlemail.com>":
535541 - ghc-syb-utils
@@ -574,6 +580,7 @@ packages:
574580 - haddock-api
575581 - here
576582 - hlibgit2
583+ - gitlib-libgit2
577584 - hostname-validate
578585 - interpolatedstring-perl6
579586 - iproute
@@ -612,6 +619,9 @@ packages:
612619 - Spock
613620 - Spock-digestive
614621 - Spock-worker
622+ - users
623+ - users-test
624+ - users-postgresql-simple
615625
616626 "Joey Eremondi <joey@eremondi.com>":
617627 - aeson-pretty
@@ -641,6 +651,11 @@ packages:
641651 "Samplecount stefan@samplecount.com @kaoskorobase":
642652 - shake-language-c
643653
654+ "Marcin Mrotek <marcin.jan.mrotek@gmail.com>":
655+ - diagrams-hsqml
656+ - type-list
657+ - vinyl-utils
658+
644659 "Marcin Mrotek <marcin.jan.mrotek@gmail.com>":
645660 - type-list
646661
@@ -703,19 +718,37 @@ packages:
703718 "Gabríel Arthúr Pétursson gabriel@system.is":
704719 - sdl2
705720
706− "Stackage upper bounds":
721+ "Leon Mergen leon@solatis.com @solatis":
722+ - network-attoparsec
723+ - network-anonymous-i2p
724+
725+ "Timothy Jones git@zmthy.io @zmthy":
726+ - cabal-test-quickcheck
727+ - http-media
728+
729+ "Greg V greg@unrelenting.technology @myfreeweb":
730+ - gitson
731+ - pcre-heavy
732+
733+ "Francesco Mazzoli f@mazzo.li @bitonic":
734+ - language-c-quote
707735
708− # https://github.com/fpco/stackage/issues/291
709− - random < 1.0.1.3
736+ "Sönke Hahn soenkehahn@gmail.com @soenkehahn":
737+ - string-conversions
738+
739+ "Oleg Grenrus oleg.grenrus@iki.fi @phadej":
740+ - waitra
741+
742+ "Adam C. Foltzer acfoltzer@galois.com @acfoltzer":
743+ - gitrev
744+
745+ "Stackage upper bounds":
710746
711747 # https://github.com/fpco/stackage/issues/390
712748 # NOTE: When this issue is resolved, remove the expected test failure
713749 # for language-ecmascript as well.
714750 - language-ecmascript < 0.17
715751
716− # https://github.com/fpco/stackage/issues/402
717− - vector-space < 0.9
718−
719752 # https://github.com/fpco/stackage/issues/407
720753 - HStringTemplate < 0.8
721754
@@ -731,22 +764,32 @@ packages:
731764 # https://github.com/fpco/stackage/issues/426
732765 - utf8-string < 1
733766
734− # https://github.com/d12frosted/CanonicalPath/issues/3
735− - system-canonicalpath < 0.3
736−
737767 # https://github.com/fpco/stackage/issues/440
738768 - th-orphans < 0.9
739769 - file-location < 0.4.7
770+ - th-desugar < 1.5.1
740771
741772 # https://github.com/fpco/stackage/issues/442
742773 - blaze-builder < 0.4
774+ - blaze-markup < 0.7
775+ - blaze-html < 0.8
743776
744777 # https://github.com/fpco/stackage/issues/443
745778 - exceptions < 0.7
746− - resourcet < 1.1.4
779+ - rest-client < 0.5
780+ - rest-types < 1.13
781+ - rest-core < 0.35
782+ - rest-gen < 0.17
783+ - rest-wai < 0.1.0.7
784+
785+ # https://github.com/fpco/stackage/issues/467
786+ - lens < 4.8
747787
748− # https://github.com/fpco/stackage/issues/445
749− - semigroupoids < 4.3
788+ # https://github.com/fpco/stackage/issues/476
789+ - vector-space < 0.10
790+
791+ # https://github.com/ekmett/linear/issues/70
792+ - linear < 1.18
750793
751794# Package flags are applied to individual packages, and override the values of
752795# global-flags
@@ -918,9 +961,6 @@ expected-test-failures:
918961 # https://github.com/BioHaskell/octree/issues/4
919962 - Octree
920963
921− # https://github.com/goldfirere/th-desugar/issues/12
922− - th-desugar
923−
924964 # https://github.com/jmillikin/haskell-filesystem/issues/3
925965 - system-filepath
926966
@@ -993,20 +1033,52 @@ expected-test-failures:
9931033 # https://github.com/haskell-distributed/distributed-process-execution/issues/2
9941034 - distributed-process-execution
9951035
1036+ # Seems to depend on mtl being installed in user package database, which
1037+ # isn't always the case (e.g., build server)
1038+ - happy
1039+
1040+ # https://github.com/jberryman/directory-tree/issues/4
1041+ - directory-tree
1042+
1043+ # https://github.com/zmthy/http-media/issues/11
1044+ - http-media
1045+
1046+ # https://github.com/ekmett/semigroupoids/issues/18
1047+ - semigroupoids
1048+
1049+ # https://github.com/ndmitchell/hoogle/issues/101
1050+ - hoogle
1051+
1052+ # https://github.com/myfreeweb/gitson/issues/1
1053+ - gitson
1054+
1055+ # https://github.com/jcristovao/enclosed-exceptions/issues/6
1056+ - enclosed-exceptions
1057+
1058+ # Expects a running PostgreSQL server
1059+ - users-postgresql-simple
1060+
1061+ # Problems with linking with system libraries on Ubuntu 12.04
1062+ - nettle
1063+
1064+ # Requires locally running services
1065+ - network-anonymous-i2p
1066+
9961067# Haddocks which are expected to fail. Same concept as expected test failures.
9971068expected-haddock-failures:
9981069 # https://github.com/acw/bytestring-progress/issues/4
9991070 - bytestring-progress
10001071
1001− # https://github.com/ekmett/gl/issues/4
1002− - gl
1003−
10041072 # https://github.com/leventov/yarr/issues/5
10051073 - yarr
10061074
10071075 # https://github.com/wereHamster/rethinkdb-client-driver/issues/1
10081076 - rethinkdb-client-driver
10091077
1078+ # Requires build before haddock, which doesn't always happen in incremental
1079+ # builds. Could consider special-casing this requirement.
1080+ - gtk
1081+
10101082# Benchmarks which should not be built. Note that Stackage does *not* generally
10111083# build benchmarks. The difference here will be whether dependencies for these
10121084# benchmarks are included or not.
debian-bootstrap.sh+20−1
@@ -18,6 +18,9 @@ apt-get install -y \
1818 build-essential \
1919 libncurses-dev \
2020 git \
21+ wget \
22+ m4 \
23+ texlive-full \
2124 libgmp3c2 \
2225 libgmp3-dev \
2326 zlib1g-dev \
@@ -34,11 +37,11 @@ apt-get install -y \
3437 llvm \
3538 libbz2-dev \
3639 libjudy-dev \
40+ libsqlite3-dev \
3741 libmysqlclient-dev \
3842 libpq-dev \
3943 libicu-dev \
4044 libssl-dev \
41− nettle-dev \
4245 libgsl0-dev \
4346 libblas-dev \
4447 liblapack-dev \
@@ -49,4 +52,20 @@ apt-get install -y \
4952 libyaml-dev \
5053 liblzma-dev \
5154 libsdl2-dev \
55+ libxss-dev \
5256 libzmq3-dev
57+
58+mkdir /tmp/nettle-build
59+(
60+cd /tmp/nettle-build
61+wget https://ftp.gnu.org/gnu/nettle/nettle-2.7.1.tar.gz
62+tar zxf nettle-2.7.1.tar.gz
63+cd nettle-2.7.1
64+./configure --prefix=/usr
65+make
66+make install
67+
68+mkdir -p /usr/lib/x86_64-linux-gnu/
69+ln -sfv /usr/lib/libnettle.so.4.7 /usr/lib/x86_64-linux-gnu/libnettle.so.4
70+)
71+rm -rf /tmp/nettle-build
stackage.cabal+7−1
@@ -1,5 +1,5 @@
11name: stackage
2−version: 0.5.2
2+version: 0.6.0.1
33synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage.
44description: Please see <http://www.stackage.org/package/stackage> for a description and documentation.
55homepage: https://github.com/fpco/stackage
@@ -23,6 +23,7 @@ library
2323 Stackage.BuildPlan
2424 Stackage.CheckBuildPlan
2525 Stackage.UpdateBuildPlan
26+ Stackage.GhcPkg
2627 Stackage.GithubPings
2728 Stackage.InstallBuild
2829 Stackage.PackageDescription
@@ -54,6 +55,7 @@ library
5455 , yaml
5556 , unix-compat
5657 , http-client
58+ , http-conduit
5759 , http-client-tls
5860 , temporary
5961 , data-default-class
@@ -63,6 +65,7 @@ library
6365 , streaming-commons >= 0.1.7.1
6466 , semigroups
6567 , xml-conduit
68+ , conduit
6669
6770executable stackage
6871 default-language: Haskell2010
@@ -72,6 +75,9 @@ executable stackage
7275 , stackage
7376 , optparse-applicative >= 0.11
7477 , system-filepath
78+ , http-client
79+ , http-client-tls
80+ , text
7581 ghc-options: -rtsopts -threaded -with-rtsopts=-N
7682
7783test-suite spec