2aa6ecc · stackage · git.iko.soy

git.iko.soy/stackage

on master help sign in

Merge branch 'incremental'

2aa6eccMichael Snoyman12 years ago

Stackage/CompleteBuild.hs+2−2

compare with master

unifiedsplit

@@ -68,7 +68,7 @@ nightlySettings :: Text -- ^ day

68 -> Settings

69nightlySettings day plan' = Settings

70 { planFile = nightlyPlanFile day

71− , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day

71+ , buildDir = fpFromText $ "builds/nightly"

72 , logDir = fpFromText $ "logs/stackage-nightly-" ++ day

73 , title = \ghcVer -> concat

74 [ "Stackage Nightly "

@@ -121,7 +121,7 @@ getSettings man (LTS bumpType) = do

121

122 return Settings

123 { planFile = newfile

124− , buildDir = fpFromText $ "builds/stackage-lts-" ++ tshow new

124+ , buildDir = fpFromText $ "builds/lts"

125 , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new

126 , title = \ghcVer -> concat

127 [ "LTS Haskell "

Stackage/GhcPkg.hsnew file+104

@@ -0,0 +1,104 @@

1+{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+-- | General commands related to ghc-pkg.

5+module Stackage.GhcPkg

6+ ( setupPackageDatabase

7+ ) where

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/PerformBuild.hs+123−27

@@ -19,11 +19,12 @@ import qualified Data.Map as Map

19import Data.NonNull (fromNullable)

20import Filesystem (canonicalizePath, createTree,

21 getWorkingDirectory, isDirectory,

22− removeTree, rename)

22+ removeTree, rename, isFile, removeFile)

23import Filesystem.Path (parent)

24import qualified Filesystem.Path as F

25import Stackage.BuildConstraints

26import Stackage.BuildPlan

27+import Stackage.GhcPkg

27import Stackage.PackageDescription

28import Stackage.PackageDescription

28import Stackage.Prelude hiding (pi)

29import Stackage.Prelude hiding (pi)

29import System.Directory (findExecutable)

30import System.Directory (findExecutable)

@@ -135,6 +136,10 @@ pbLibDir pb = pbInstallDest pb </> "lib"

135pbDataDir pb = pbInstallDest pb </> "share"

136pbDataDir pb = pbInstallDest pb </> "share"

136pbDocDir pb = pbInstallDest pb </> "doc"

137pbDocDir pb = pbInstallDest pb </> "doc"

137

138

139+-- | Directory keeping previous result info

140+pbPrevResDir :: PerformBuild -> FilePath

141+pbPrevResDir pb = pbInstallDest pb </> "prevres"

142+

138performBuild :: PerformBuild -> IO [Text]

143performBuild :: PerformBuild -> IO [Text]

139performBuild pb = do

144performBuild pb = do

140 cwd <- getWorkingDirectory

145 cwd <- getWorkingDirectory

@@ -162,12 +167,13 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do

162 $ \ClosedStream Inherited Inherited -> return ()

167 $ \ClosedStream Inherited Inherited -> return ()

163

168

164 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)

169 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)

165− mapM_ removeTree' [pbInstallDest, pbLogDir]

170+ removeTree' pbLogDir

166

171

167− forM_ (pbDatabase pb) $ \db -> do

172+ forM_ (pbDatabase pb) $ \db ->

173+ unlessM (isFile $ db </> "package.cache") $ do

168− createTree $ parent db

174+ createTree $ parent db

169− withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])

175+ withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])

170− $ \ClosedStream Inherited Inherited -> return ()

176+ $ \ClosedStream Inherited Inherited -> return ()

171 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"

177 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"

172 copyBuiltInHaddocks (pbDocDir pb)

178 copyBuiltInHaddocks (pbDocDir pb)

173

179

@@ -187,7 +193,15 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do

187 env <- getEnvironment

193 env <- getEnvironment

188 haddockFiles <- newTVarIO mempty

194 haddockFiles <- newTVarIO mempty

189

195

196+ registeredPackages <- setupPackageDatabase

197+ (pbDatabase pb)

198+ (pbDocDir pb)

199+ pbLog

200+ (ppVersion <$> bpPackages pbPlan)

201+ (deletePreviousResults pb)

202+

190− forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild

203+ forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages

204+ SingleBuild

191 { sbSem = sem

205 { sbSem = sem

192 , sbErrsVar = errsVar

206 , sbErrsVar = errsVar

193 , sbWarningsVar = warningsVar

207 , sbWarningsVar = warningsVar

@@ -249,8 +263,10 @@ data SingleBuild = SingleBuild

249 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file

263 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file

250 }

264 }

251

265

252−singleBuild :: PerformBuild -> SingleBuild -> IO ()

266+singleBuild :: PerformBuild

267+ -> Set PackageName -- ^ registered packages

268+ -> SingleBuild -> IO ()

253−singleBuild pb@PerformBuild {..} SingleBuild {..} =

269+singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =

254 withCounter sbActive

270 withCounter sbActive

255 $ handle updateErrs

271 $ handle updateErrs

256 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))

272 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))

@@ -262,11 +278,13 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =

262 let wfd comps =

278 let wfd comps =

263 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo

279 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo

264 . withTSem sbSem

280 . withTSem sbSem

265− wfd libComps buildLibrary

281+ withUnpacked <- wfd libComps buildLibrary

266

282

267− wfd testComps runTests

283+ wfd testComps (runTests withUnpacked)

268

284

285+ pname = piName sbPackageInfo

286+ pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)

269− name = display $ piName sbPackageInfo

287+ name = display pname

270 namever = concat

288 namever = concat

271 [ name

289 [ name

272 , "-"

290 , "-"

@@ -335,19 +353,37 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =

335 buildLibrary = wf libOut $ \outH -> do

353 buildLibrary = wf libOut $ \outH -> do

336 let run a b = do when pbVerbose $ log' (unwords (a : b))

354 let run a b = do when pbVerbose $ log' (unwords (a : b))

337 runChild outH a b

355 runChild outH a b

338− log' $ "Unpacking " ++ namever

339− runParent outH "cabal" ["unpack", namever]

340−

341− log' $ "Configuring " ++ namever

342− run "cabal" $ "configure" : configArgs

343

356

357+ isUnpacked <- newIORef False

358+ let withUnpacked inner = do

359+ unlessM (readIORef isUnpacked) $ do

360+ log' $ "Unpacking " ++ namever

361+ runParent outH "cabal" ["unpack", namever]

362+ writeIORef isUnpacked True

363+ inner

364+

365+ isConfiged <- newIORef False

366+ let withConfiged inner = withUnpacked $ do

367+ unlessM (readIORef isConfiged) $ do

368+ log' $ "Configuring " ++ namever

369+ run "cabal" $ "configure" : configArgs

370+ writeIORef isConfiged True

371+ inner

372+

373+ prevBuildResult <- getPreviousResult pb Build pident

374+ unless (prevBuildResult == PRSuccess) $ withConfiged $ do

375+ assert (pname `notMember` registeredPackages) $ do

376+ deletePreviousResults pb pident

377+

344− log' $ "Building " ++ namever

378+ log' $ "Building " ++ namever

345− run "cabal" ["build"]

379+ run "cabal" ["build"]

346−

380+

347− log' $ "Copying/registering " ++ namever

381+ log' $ "Copying/registering " ++ namever

348− run "cabal" ["copy"]

382+ run "cabal" ["copy"]

349− withMVar sbRegisterMutex $ const $

383+ withMVar sbRegisterMutex $ const $

350− run "cabal" ["register"]

384+ run "cabal" ["register"]

385+

386+ savePreviousResult pb Build pident True

351

387

352 -- Even if the tests later fail, we can allow other libraries to build

388 -- Even if the tests later fail, we can allow other libraries to build

353 -- on top of our successful results

389 -- on top of our successful results

@@ -357,7 +393,11 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =

357 -- dependency's haddocks before this finishes

393 -- dependency's haddocks before this finishes

358 atomically $ putTMVar (piResult sbPackageInfo) True

394 atomically $ putTMVar (piResult sbPackageInfo) True

359

395

396+ prevHaddockResult <- getPreviousResult pb Haddock pident

397+ let needHaddock = pbEnableHaddock

398+ && checkPrevResult prevHaddockResult pcHaddocks

360− when (pbEnableHaddock && pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do

399+ && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)

400+ when needHaddock $ withConfiged $ do

361 log' $ "Haddocks " ++ namever

401 log' $ "Haddocks " ++ namever

362 hfs <- readTVarIO sbHaddockFiles

402 hfs <- readTVarIO sbHaddockFiles

363 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat

403 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat

@@ -392,15 +432,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =

392 $ modifyTVar sbHaddockFiles

432 $ modifyTVar sbHaddockFiles

393 $ insertMap namever newPath

433 $ insertMap namever newPath

394

434

435+ savePreviousResult pb Haddock pident $ either (const False) (const True) eres

395 case (eres, pcHaddocks) of

436 case (eres, pcHaddocks) of

396 (Left e, ExpectSuccess) -> throwM e

437 (Left e, ExpectSuccess) -> throwM e

397 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"

438 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"

398 _ -> return ()

439 _ -> return ()

399

440

441+ return withUnpacked

442+

400− runTests = wf testOut $ \outH -> do

443+ runTests withUnpacked = wf testOut $ \outH -> do

401 let run = runChild outH

444 let run = runChild outH

402

445

446+ prevTestResult <- getPreviousResult pb Test pident

403− when (pbEnableTests && pcTests /= Don'tBuild) $ do

447+ let needTest = pbEnableTests

448+ && checkPrevResult prevTestResult pcTests

449+ when needTest $ withUnpacked $ do

404 log' $ "Test configure " ++ namever

450 log' $ "Test configure " ++ namever

405 run "cabal" $ "configure" : "--enable-tests" : configArgs

451 run "cabal" $ "configure" : "--enable-tests" : configArgs

406

452

@@ -411,6 +457,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =

411 log' $ "Test run " ++ namever

457 log' $ "Test run " ++ namever

412 run "cabal" ["test", "--log=" ++ fpToText testRunOut]

458 run "cabal" ["test", "--log=" ++ fpToText testRunOut]

413

459

460+ savePreviousResult pb Test pident $ either (const False) (const True) eres

414 case (eres, pcTests) of

461 case (eres, pcTests) of

415 (Left e, ExpectSuccess) -> throwM e

462 (Left e, ExpectSuccess) -> throwM e

416 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"

463 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"

@@ -453,3 +500,52 @@ copyBuiltInHaddocks docdir = do

453 src <- canonicalizePath

500 src <- canonicalizePath

454 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")

501 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")

455 copyDir src docdir

502 copyDir src docdir

503+

504+------------- Previous results

505+

506+-- | The previous actions that can be run

507+data ResultType = Build | Haddock | Test

508+ deriving (Show, Enum, Eq, Ord, Bounded, Read)

509+

510+-- | The result generated on a previous run

511+data PrevResult = PRNoResult | PRSuccess | PRFailure

512+ deriving (Show, Enum, Eq, Ord, Bounded, Read)

513+

514+-- | Check if we should rerun based on a PrevResult and the expected status

515+checkPrevResult :: PrevResult -> TestState -> Bool

516+checkPrevResult _ Don'tBuild = False

517+checkPrevResult PRNoResult _ = True

518+checkPrevResult PRSuccess _ = False

519+checkPrevResult PRFailure ExpectSuccess = True

520+checkPrevResult PRFailure _ = False

521+

522+withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a

523+withPRPath pb rt ident inner = do

524+ createTree $ parent fp

525+ inner fp

526+ where

527+ fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)

528+

529+successBS, failureBS :: ByteString

530+successBS = "success"

531+failureBS = "failure"

532+

533+getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult

534+getPreviousResult w x y = withPRPath w x y $ \fp -> do

535+ eres <- tryIO $ readFile fp

536+ return $ case eres of

537+ Right bs

538+ | bs == successBS -> PRSuccess

539+ | bs == failureBS -> PRFailure

540+ _ -> PRNoResult

541+

542+savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()

543+savePreviousResult pb rt ident res =

544+ withPRPath pb rt ident $ \fp -> writeFile fp $

545+ if res then successBS else failureBS

546+

547+deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()

548+deletePreviousResults pb name =

549+ forM_ [minBound..maxBound] $ \rt ->

550+ withPRPath pb rt name $ \fp ->

551+ void $ tryIO $ removeFile fp

stackage.cabal+2

@@ -23,6 +23,7 @@ library

23 Stackage.BuildPlan

24 Stackage.CheckBuildPlan

25 Stackage.UpdateBuildPlan

26+ Stackage.GhcPkg

26 Stackage.GithubPings

27 Stackage.GithubPings

27 Stackage.InstallBuild

28 Stackage.InstallBuild

28 Stackage.PackageDescription

29 Stackage.PackageDescription

@@ -63,6 +64,7 @@ library

63 , streaming-commons >= 0.1.7.1

64 , streaming-commons >= 0.1.7.1

64 , semigroups

65 , semigroups

65 , xml-conduit

66 , xml-conduit

67+ , conduit

67executable stackage

69executable stackage

68 default-language: Haskell2010

70 default-language: Haskell2010