4624ae2 · stackage · git.iko.soy

Stackage/Build.hs+7−5

@@ -5,6 +5,7 @@ module Stackage.Build

55import Control.Monad (unless)

66import Stackage.CheckPlan

77import Stackage.InstallInfo

8+import Stackage.Tarballs

89import Stackage.Test

910import Stackage.Util

1011import System.Exit (ExitCode (ExitSuccess), exitWith)

@@ -14,17 +15,18 @@ import System.Process (runProcess, waitForProcess)

1415build :: IO ()

1516build = do

1617 ii <- getInstallInfo

18+

1719 checkPlan ii

20+ putStrLn "No mismatches, starting the sandboxed build."

1821

1922 rm_r "cabal-dev"

20−

21− putStrLn "No mismatches, good to go!"

22−

2323 ph <- withBinaryFile "build.log" WriteMode $ \handle ->

2424 runProcess "cabal-dev" ("install":"-fnetwork23":iiPackageList ii) Nothing Nothing Nothing (Just handle) (Just handle)

2525 ec <- waitForProcess ph

2626 unless (ec == ExitSuccess) $ exitWith ec

2727

28− putStrLn "Environment built, beginning individual test suites"

29−

28+ putStrLn "Sandbox built, beginning individual test suites"

3029 runTestSuites ii

30+

31+ putStrLn "All test suites that were expected to pass did pass, building tarballs."

32+ makeTarballs ii

Stackage/Init.hsnew file+32

@@ -0,0 +1,32 @@

1+module Stackage.Init (stackageInit) where

2+

3+import Data.List (isInfixOf, isPrefixOf)

4+import Stackage.Util

5+import System.FilePath ((</>))

6+

7+stackageInit :: IO ()

8+stackageInit = do

9+ c <- getCabalRoot

10+ let config = c </> "config"

11+ orig <- readFile config

12+ -- bypass laziness

13+ _ <- return $! length orig

14+ writeFile config $ unlines $ go $ lines orig

15+ where

16+ go = addStackage

17+ . map commentHackage

18+ . filter (\s -> not $ "stackage" `isInfixOf` s)

19+

20+ addStackage [] = stackageLines []

21+ addStackage (l:ls)

22+ | "remote-repo-cache:" `isPrefixOf` l = stackageLines $ l : ls

23+ | otherwise = l : addStackage ls

24+

25+ stackageLines x =

26+ "remote-repo: stackage:http://hackage.haskell.org/packages/archive"

27+ : "remote-repo: stackage-extra:http://hackage.haskell.org/packages/archive"

28+ : x

29+

30+ commentHackage s

31+ | s == "remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive" = "--" ++ s

32+ | otherwise = s

Stackage/LoadDatabase.hs+3−20

@@ -1,12 +1,9 @@

11module Stackage.LoadDatabase where

22

33import qualified Codec.Archive.Tar as Tar

4−import qualified Codec.Archive.Tar.Entry as TarEntry

54import Control.Exception (throwIO)

6−import Control.Monad (guard)

75import qualified Data.ByteString.Lazy as L

86import qualified Data.ByteString.Lazy.Char8 as L8

9−import Data.List (stripPrefix)

107import qualified Data.Map as Map

118import Data.Monoid (Monoid (..))

129import Data.Set (member)

@@ -18,11 +15,9 @@ import Distribution.PackageDescription (condExecutables,

1815 condTreeConstraints)

1916import Distribution.PackageDescription.Parse (ParseResult (ParseOk),

2017 parsePackageDescription)

21−import Distribution.Text (simpleParse)

2218import Distribution.Version (withinRange)

2319import Stackage.Types

24−import System.Directory (getAppUserDataDirectory)

25−import System.FilePath ((</>))

20+import Stackage.Util

2621

2722-- | Load the raw package database.

2823--

@@ -39,8 +34,7 @@ loadPackageDB :: Set PackageName -- ^ core packages

3934 -> Map PackageName VersionRange -- ^ additional deps

4035 -> IO PackageDB

4136loadPackageDB core deps = do

42− c <- getAppUserDataDirectory "cabal"

43− let tarName = c </> "packages" </> "hackage.haskell.org" </> "00-index.tar"

37+ tarName <- getTarballName

4438 lbs <- L.readFile tarName

4539 addEntries mempty $ Tar.read lbs

4640 where

@@ -51,7 +45,7 @@ loadPackageDB core deps = do

5145

5246 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB

5347 addEntry pdb e =

54− case getPackageVersion $ TarEntry.fromTarPathToPosixPath (TarEntry.entryTarPath e) of

48+ case getPackageVersion e of

5549 Nothing -> return pdb

5650 Just (p, v)

5751 | p `member` core -> return pdb

@@ -78,14 +72,3 @@ loadPackageDB core deps = do

7872 _ -> mempty

7973 where

8074 go = Set.fromList . map (\(Dependency p _) -> p) . condTreeConstraints

81−

82− getPackageVersion :: FilePath -> Maybe (PackageName, Version)

83− getPackageVersion fp = do

84− let (package', s1) = break (== '/') fp

85− package = PackageName package'

86− s2 <- stripPrefix "/" s1

87− let (version', s3) = break (== '/') s2

88− version <- simpleParse version'

89− s4 <- stripPrefix "/" s3

90− guard $ s4 == package' ++ ".cabal"

91− Just (package, version)

Stackage/Tarballs.hsnew file+44

@@ -0,0 +1,44 @@

1+module Stackage.Tarballs

2+ ( makeTarballs

3+ ) where

4+

5+import qualified Codec.Archive.Tar as Tar

6+import Control.Exception (throwIO)

7+import qualified Data.ByteString.Lazy as L

8+import qualified Data.Map as Map

9+import qualified Data.Set as Set

10+import Stackage.Types

11+import Stackage.Util

12+import System.Directory (createDirectoryIfMissing)

13+import System.FilePath (takeDirectory)

14+

15+makeTarballs :: InstallInfo -> IO ()

16+makeTarballs ii = do

17+ tarName <- getTarballName

18+ origEntries <- fmap Tar.read $ L.readFile tarName

19+ (stableEntries, extraEntries) <- loop id id origEntries

20+

21+ (stableTar, extraTar) <- getStackageTarballNames

22+

23+ createDirectoryIfMissing True $ takeDirectory stableTar

24+ L.writeFile stableTar $ Tar.write stableEntries

25+

26+ createDirectoryIfMissing True $ takeDirectory extraTar

27+ L.writeFile extraTar $ Tar.write extraEntries

28+ where

29+ loop _ _ (Tar.Fail err) = throwIO err

30+ loop stable extra Tar.Done = return (stable [], extra [])

31+ loop stable extra (Tar.Next e es) =

32+ loop stable' extra' es

33+ where

34+ (stable', extra') =

35+ case getPackageVersion e of

36+ Nothing -> (stable, extra)

37+ Just (package, version) ->

38+ case Map.lookup package $ iiPackages ii of

39+ Just version'

40+ | version == version' -> (stable . (e:), extra)

41+ | otherwise -> (stable, extra)

42+ Nothing

43+ | package `Set.member` iiCore ii -> (stable, extra)

44+ | otherwise -> (stable, extra . (e:))

Stackage/Test.hs+2−4

@@ -2,7 +2,7 @@ module Stackage.Test

22 ( runTestSuites

33 ) where

44

5−import Control.Monad (foldM, when)

5+import Control.Monad (foldM, unless, when)

66import qualified Data.Map as Map

77import qualified Data.Set as Set

88import Stackage.Config

@@ -21,9 +21,7 @@ runTestSuites ii = do

2121 rm_r testdir

2222 createDirectory testdir

2323 allPass <- foldM (runTestSuite testdir) True $ Map.toList $ iiPackages ii

24− if allPass

25− then putStrLn "All test suites that were expected to pass did pass"

26− else error $ "There were failures, please see the logs in " ++ testdir

24+ unless allPass $ error $ "There were failures, please see the logs in " ++ testdir

2725

2826runTestSuite :: FilePath -> Bool -> (PackageName, Version) -> IO Bool

2927runTestSuite testdir prevPassed pair@(packageName, _) = do

Stackage/Util.hs+46−7

@@ -1,13 +1,19 @@

11module Stackage.Util where

22

3−import Control.Monad (when)

4−import qualified Data.Map as Map

5−import qualified Data.Set as Set

6−import Data.Version (showVersion)

7−import Distribution.Version (thisVersion)

3+import qualified Codec.Archive.Tar as Tar

4+import qualified Codec.Archive.Tar.Entry as TarEntry

5+import Control.Monad (guard, when)

6+import Data.List (stripPrefix)

7+import qualified Data.Map as Map

8+import qualified Data.Set as Set

9+import Data.Version (showVersion)

10+import Distribution.Text (simpleParse)

11+import Distribution.Version (thisVersion)

812import Stackage.Types

9−import System.Directory (doesDirectoryExist,

10− removeDirectoryRecursive)

13+import System.Directory (doesDirectoryExist,

14+ removeDirectoryRecursive)

15+import System.Directory (getAppUserDataDirectory)

16+import System.FilePath ((</>))

1117

1218identsToRanges :: Set PackageIdentifier -> Map PackageName VersionRange

1319identsToRanges =

@@ -22,3 +28,36 @@ rm_r :: FilePath -> IO ()

2228rm_r fp = do

2329 exists <- doesDirectoryExist fp

2430 when exists $ removeDirectoryRecursive fp

31+

32+getCabalRoot :: IO FilePath

33+getCabalRoot = getAppUserDataDirectory "cabal"

34+

35+-- | Name of the 00-index.tar downloaded from Hackage.

36+getTarballName :: IO FilePath

37+getTarballName = do

38+ c <- getCabalRoot

39+ return $ c </> "packages" </> "hackage.haskell.org" </> "00-index.tar"

40+

41+stableRepoName, extraRepoName :: String

42+stableRepoName = "stackage"

43+extraRepoName = "stackage-extra"

44+

45+-- | Locations for the stackage and stackage-extra tarballs

46+getStackageTarballNames :: IO (FilePath, FilePath)

47+getStackageTarballNames = do

48+ c <- getCabalRoot

49+ let f x = c </> "packages" </> x </> "00-index.tar"

50+ return (f stableRepoName, f extraRepoName)

51+

52+getPackageVersion :: Tar.Entry -> Maybe (PackageName, Version)

53+getPackageVersion e = do

54+ let (package', s1) = break (== '/') fp

55+ package = PackageName package'

56+ s2 <- stripPrefix "/" s1

57+ let (version', s3) = break (== '/') s2

58+ version <- simpleParse version'

59+ s4 <- stripPrefix "/" s3

60+ guard $ s4 == package' ++ ".cabal"

61+ Just (package, version)

62+ where

63+ fp = TarEntry.fromTarPathToPosixPath $ TarEntry.entryTarPath e

app/stackage.hs+16−2

@@ -1,4 +1,18 @@

1−import Stackage.Build (build)

1+import Stackage.Build (build)

2+import Stackage.Init (stackageInit)

3+import System.Environment (getArgs, getProgName)

24

35main :: IO ()

4−main = build

6+main = do

7+ args <- getArgs

8+ case args of

9+ ["build"] -> build

10+ ["init"] -> stackageInit

11+ ["update"] -> stackageInit >> error "FIXME update"

12+ _ -> do

13+ pn <- getProgName

14+ putStrLn $ "Usage: " ++ pn ++ " <command>"

15+ putStrLn "Available commands:"

16+ putStrLn " update Download updated Stackage databases. Automatically calls init."

17+ putStrLn " init Initialize your cabal file to use Stackage"

18+ putStrLn " build Build the package databases (maintainers only)"

stackage.cabal+2

@@ -23,8 +23,10 @@ library

2323 Stackage.Config

2424 Stackage.InstallInfo

2525 Stackage.CheckPlan

26+ Stackage.Tarballs

2627 Stackage.Test

2728 Stackage.Build

29+ Stackage.Init

2830 build-depends: base >= 4 && < 5

2931 , containers

3032 , Cabal