Build tarballs, init

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

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

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           Stackage.Util
-import           System.FilePath                       ((</>))
 
 -- | 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"
+    tarName <- getTarballName
-    let tarName = c </> "packages" </> "hackage.haskell.org" </> "00-index.tar"
     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)

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:))

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
+    unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
-        then putStrLn "All test suites that were expected to pass did pass"
-        else error $ "There were failures, please see the logs in " ++ testdir
 
 runTestSuite :: FilePath -> Bool -> (PackageName, Version) -> IO Bool
 runTestSuite testdir prevPassed pair@(packageName, _) = do

Stackage/Util.hs

@@ -1,13 +1,19 @@
 module Stackage.Util where
 
-import           Control.Monad        (when)
+import qualified Codec.Archive.Tar       as Tar
-import qualified Data.Map             as Map
+import qualified Codec.Archive.Tar.Entry as TarEntry
-import qualified Data.Set             as Set
+import           Control.Monad           (guard, when)
-import           Data.Version         (showVersion)
+import           Data.List               (stripPrefix)
-import           Distribution.Version (thisVersion)
+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,
+import           System.Directory        (doesDirectoryExist,
-                                       removeDirectoryRecursive)
+                                          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

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 ++ " <command>"
+            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)"

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