From 4624ae2d2a167407b8082201a0235e0179e5b12c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 22 Nov 2012 10:25:03 +0200 Subject: [PATCH] Build tarballs, init --- Stackage/Build.hs | 12 +++++---- Stackage/Init.hs | 32 ++++++++++++++++++++++++ Stackage/LoadDatabase.hs | 23 +++-------------- Stackage/Tarballs.hs | 44 +++++++++++++++++++++++++++++++++ Stackage/Test.hs | 6 ++--- Stackage/Util.hs | 53 ++++++++++++++++++++++++++++++++++------ app/stackage.hs | 18 ++++++++++++-- stackage.cabal | 2 ++ 8 files changed, 152 insertions(+), 38 deletions(-) create mode 100644 Stackage/Init.hs create mode 100644 Stackage/Tarballs.hs diff --git a/Stackage/Build.hs b/Stackage/Build.hs index a8d3f61a..a65672e3 100644 --- a/Stackage/Build.hs +++ b/Stackage/Build.hs @@ -5,6 +5,7 @@ module Stackage.Build import Control.Monad (unless) import Stackage.CheckPlan import Stackage.InstallInfo +import Stackage.Tarballs import Stackage.Test import Stackage.Util import System.Exit (ExitCode (ExitSuccess), exitWith) @@ -14,17 +15,18 @@ import System.Process (runProcess, waitForProcess) build :: IO () build = do ii <- getInstallInfo + checkPlan ii + putStrLn "No mismatches, starting the sandboxed build." rm_r "cabal-dev" - - putStrLn "No mismatches, good to go!" - ph <- withBinaryFile "build.log" WriteMode $ \handle -> runProcess "cabal-dev" ("install":"-fnetwork23":iiPackageList ii) Nothing Nothing Nothing (Just handle) (Just handle) ec <- waitForProcess ph unless (ec == ExitSuccess) $ exitWith ec - putStrLn "Environment built, beginning individual test suites" - + putStrLn "Sandbox built, beginning individual test suites" runTestSuites ii + + putStrLn "All test suites that were expected to pass did pass, building tarballs." + makeTarballs ii diff --git a/Stackage/Init.hs b/Stackage/Init.hs new file mode 100644 index 00000000..b8b599c5 --- /dev/null +++ b/Stackage/Init.hs @@ -0,0 +1,32 @@ +module Stackage.Init (stackageInit) where + +import Data.List (isInfixOf, isPrefixOf) +import Stackage.Util +import System.FilePath (()) + +stackageInit :: IO () +stackageInit = do + c <- getCabalRoot + let config = c "config" + orig <- readFile config + -- bypass laziness + _ <- return $! length orig + writeFile config $ unlines $ go $ lines orig + where + go = addStackage + . map commentHackage + . filter (\s -> not $ "stackage" `isInfixOf` s) + + addStackage [] = stackageLines [] + addStackage (l:ls) + | "remote-repo-cache:" `isPrefixOf` l = stackageLines $ l : ls + | otherwise = l : addStackage ls + + stackageLines x = + "remote-repo: stackage:http://hackage.haskell.org/packages/archive" + : "remote-repo: stackage-extra:http://hackage.haskell.org/packages/archive" + : x + + commentHackage s + | s == "remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive" = "--" ++ s + | otherwise = s diff --git a/Stackage/LoadDatabase.hs b/Stackage/LoadDatabase.hs index b6f709f1..362bf08a 100644 --- a/Stackage/LoadDatabase.hs +++ b/Stackage/LoadDatabase.hs @@ -1,12 +1,9 @@ module Stackage.LoadDatabase where import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as TarEntry import Control.Exception (throwIO) -import Control.Monad (guard) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.List (stripPrefix) import qualified Data.Map as Map import Data.Monoid (Monoid (..)) import Data.Set (member) @@ -18,11 +15,9 @@ import Distribution.PackageDescription (condExecutables, condTreeConstraints) import Distribution.PackageDescription.Parse (ParseResult (ParseOk), parsePackageDescription) -import Distribution.Text (simpleParse) import Distribution.Version (withinRange) import Stackage.Types -import System.Directory (getAppUserDataDirectory) -import System.FilePath (()) +import Stackage.Util -- | Load the raw package database. -- @@ -39,8 +34,7 @@ loadPackageDB :: Set PackageName -- ^ core packages -> Map PackageName VersionRange -- ^ additional deps -> IO PackageDB loadPackageDB core deps = do - c <- getAppUserDataDirectory "cabal" - let tarName = c "packages" "hackage.haskell.org" "00-index.tar" + tarName <- getTarballName lbs <- L.readFile tarName addEntries mempty $ Tar.read lbs where @@ -51,7 +45,7 @@ loadPackageDB core deps = do addEntry :: PackageDB -> Tar.Entry -> IO PackageDB addEntry pdb e = - case getPackageVersion $ TarEntry.fromTarPathToPosixPath (TarEntry.entryTarPath e) of + case getPackageVersion e of Nothing -> return pdb Just (p, v) | p `member` core -> return pdb @@ -78,14 +72,3 @@ loadPackageDB core deps = do _ -> mempty where go = Set.fromList . map (\(Dependency p _) -> p) . condTreeConstraints - - getPackageVersion :: FilePath -> Maybe (PackageName, Version) - getPackageVersion fp = do - let (package', s1) = break (== '/') fp - package = PackageName package' - s2 <- stripPrefix "/" s1 - let (version', s3) = break (== '/') s2 - version <- simpleParse version' - s4 <- stripPrefix "/" s3 - guard $ s4 == package' ++ ".cabal" - Just (package, version) diff --git a/Stackage/Tarballs.hs b/Stackage/Tarballs.hs new file mode 100644 index 00000000..b7e5903a --- /dev/null +++ b/Stackage/Tarballs.hs @@ -0,0 +1,44 @@ +module Stackage.Tarballs + ( makeTarballs + ) where + +import qualified Codec.Archive.Tar as Tar +import Control.Exception (throwIO) +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as Map +import qualified Data.Set as Set +import Stackage.Types +import Stackage.Util +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) + +makeTarballs :: InstallInfo -> IO () +makeTarballs ii = do + tarName <- getTarballName + origEntries <- fmap Tar.read $ L.readFile tarName + (stableEntries, extraEntries) <- loop id id origEntries + + (stableTar, extraTar) <- getStackageTarballNames + + createDirectoryIfMissing True $ takeDirectory stableTar + L.writeFile stableTar $ Tar.write stableEntries + + createDirectoryIfMissing True $ takeDirectory extraTar + L.writeFile extraTar $ Tar.write extraEntries + where + loop _ _ (Tar.Fail err) = throwIO err + loop stable extra Tar.Done = return (stable [], extra []) + loop stable extra (Tar.Next e es) = + loop stable' extra' es + where + (stable', extra') = + case getPackageVersion e of + Nothing -> (stable, extra) + Just (package, version) -> + case Map.lookup package $ iiPackages ii of + Just version' + | version == version' -> (stable . (e:), extra) + | otherwise -> (stable, extra) + Nothing + | package `Set.member` iiCore ii -> (stable, extra) + | otherwise -> (stable, extra . (e:)) diff --git a/Stackage/Test.hs b/Stackage/Test.hs index 7e818637..e06513f1 100644 --- a/Stackage/Test.hs +++ b/Stackage/Test.hs @@ -2,7 +2,7 @@ module Stackage.Test ( runTestSuites ) where -import Control.Monad (foldM, when) +import Control.Monad (foldM, unless, when) import qualified Data.Map as Map import qualified Data.Set as Set import Stackage.Config @@ -21,9 +21,7 @@ runTestSuites ii = do rm_r testdir createDirectory testdir allPass <- foldM (runTestSuite testdir) True $ Map.toList $ iiPackages ii - if allPass - then putStrLn "All test suites that were expected to pass did pass" - else error $ "There were failures, please see the logs in " ++ testdir + unless allPass $ error $ "There were failures, please see the logs in " ++ testdir runTestSuite :: FilePath -> Bool -> (PackageName, Version) -> IO Bool runTestSuite testdir prevPassed pair@(packageName, _) = do diff --git a/Stackage/Util.hs b/Stackage/Util.hs index 037a25c5..8f146508 100644 --- a/Stackage/Util.hs +++ b/Stackage/Util.hs @@ -1,13 +1,19 @@ module Stackage.Util where -import Control.Monad (when) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Version (showVersion) -import Distribution.Version (thisVersion) +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as TarEntry +import Control.Monad (guard, when) +import Data.List (stripPrefix) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Version (showVersion) +import Distribution.Text (simpleParse) +import Distribution.Version (thisVersion) import Stackage.Types -import System.Directory (doesDirectoryExist, - removeDirectoryRecursive) +import System.Directory (doesDirectoryExist, + removeDirectoryRecursive) +import System.Directory (getAppUserDataDirectory) +import System.FilePath (()) identsToRanges :: Set PackageIdentifier -> Map PackageName VersionRange identsToRanges = @@ -22,3 +28,36 @@ rm_r :: FilePath -> IO () rm_r fp = do exists <- doesDirectoryExist fp when exists $ removeDirectoryRecursive fp + +getCabalRoot :: IO FilePath +getCabalRoot = getAppUserDataDirectory "cabal" + +-- | Name of the 00-index.tar downloaded from Hackage. +getTarballName :: IO FilePath +getTarballName = do + c <- getCabalRoot + return $ c "packages" "hackage.haskell.org" "00-index.tar" + +stableRepoName, extraRepoName :: String +stableRepoName = "stackage" +extraRepoName = "stackage-extra" + +-- | Locations for the stackage and stackage-extra tarballs +getStackageTarballNames :: IO (FilePath, FilePath) +getStackageTarballNames = do + c <- getCabalRoot + let f x = c "packages" x "00-index.tar" + return (f stableRepoName, f extraRepoName) + +getPackageVersion :: Tar.Entry -> Maybe (PackageName, Version) +getPackageVersion e = do + let (package', s1) = break (== '/') fp + package = PackageName package' + s2 <- stripPrefix "/" s1 + let (version', s3) = break (== '/') s2 + version <- simpleParse version' + s4 <- stripPrefix "/" s3 + guard $ s4 == package' ++ ".cabal" + Just (package, version) + where + fp = TarEntry.fromTarPathToPosixPath $ TarEntry.entryTarPath e diff --git a/app/stackage.hs b/app/stackage.hs index b2d94425..7b173a11 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -1,4 +1,18 @@ -import Stackage.Build (build) +import Stackage.Build (build) +import Stackage.Init (stackageInit) +import System.Environment (getArgs, getProgName) main :: IO () -main = build +main = do + args <- getArgs + case args of + ["build"] -> build + ["init"] -> stackageInit + ["update"] -> stackageInit >> error "FIXME update" + _ -> do + pn <- getProgName + putStrLn $ "Usage: " ++ pn ++ " " + putStrLn "Available commands:" + putStrLn " update Download updated Stackage databases. Automatically calls init." + putStrLn " init Initialize your cabal file to use Stackage" + putStrLn " build Build the package databases (maintainers only)" diff --git a/stackage.cabal b/stackage.cabal index b5a9d203..12862811 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -23,8 +23,10 @@ library Stackage.Config Stackage.InstallInfo Stackage.CheckPlan + Stackage.Tarballs Stackage.Test Stackage.Build + Stackage.Init build-depends: base >= 4 && < 5 , containers , Cabal