diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Galois, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Galois, Inc nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,41 @@ +import Control.Monad ( unless ) +import Distribution.Simple +import Distribution.PackageDescription ( PackageDescription(..), executables, + hsSourceDirs, exeName, buildInfo ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo, buildDir ) +import Distribution.Simple.Setup ( BuildFlags, buildVerbose ) + +import Distribution.Simple.Utils ( rawSystemExit ) +import Distribution.Verbosity ( Verbosity ) + +import System.Directory ( doesDirectoryExist ) +import System.FilePath ( () ) + +main = defaultMainWithHooks $ + simpleUserHooks { buildHook = getCabalInstallSource } + +getCabalInstallSource :: PackageDescription -> LocalBuildInfo -> UserHooks + -> BuildFlags -> IO () +getCabalInstallSource pkgDesc lbi hooks flags = + do -- cabal-install fails (exit 1) if the target unpack dir exists. + exists <- doesDirectoryExist cabalInstallDir + unless exists $ rawSystemExit v unpackCommand args + buildHook simpleUserHooks updatedSrcDesc lbi hooks flags + where v = buildVerbose flags + unpackCommand = "cabal" + srcDir = buildDir lbi + cabalInstallName = "cabal-install-0.8.2" + cabalInstallCabal = "cabal-install.cabal" + cabalInstallDir = srcDir cabalInstallName + args = ["unpack", "--dest="++srcDir, cabalInstallName] + updatedSrcDesc = addSrcDirs pkgDesc cabalInstallDir + +addSrcDirs :: PackageDescription -> FilePath -> PackageDescription +addSrcDirs pkgDesc path = + let notTargetTestExe exe = exeName exe /= "cabal-dev-test" + updateExe exe | notTargetTestExe exe = id exe + | otherwise = updateSrcDirs exe + updateSrcDirs exe = exe { + buildInfo = (buildInfo exe) { + hsSourceDirs = (hsSourceDirs $ buildInfo exe) ++ [path] }} + in pkgDesc { executables = map updateExe $ executables pkgDesc } diff --git a/admin/00-index.tar b/admin/00-index.tar new file mode 100644 Binary files /dev/null and b/admin/00-index.tar differ diff --git a/admin/cabal-config.in b/admin/cabal-config.in new file mode 100644 --- /dev/null +++ b/admin/cabal-config.in @@ -0,0 +1,84 @@ +-- -*-haskell-cabal-*- +-- +-- This is the configuration file for the 'cabal' command line tool. + +-- The available configuration options are listed below. +-- Some of them have default values listed. + +-- Lines (like this one) beginning with '--' are comments. +-- Be careful with spaces and indentation because they are +-- used to indicate layout for nested sections. + +-- Cabal-dev replaces ~ and . in this file to generate a usable cabal +-- configuration file This breaks this file for direct use by +-- cabal-install, the behavior is undefined for cabal-install. +-- +-- These symbols are redfined to mean the following: +-- +-- ~ Tilde now means 'the user's default cabal directory' This is +-- defined by getAppUserDataDirectory, which differs somewhat on +-- each OS. +-- +-- . "dot" means 'the sandbox directory that cabal-dev is using' +-- + +remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive +remote-repo-cache: ~/packages +local-repo: ./packages +-- local-repo: +-- verbose: 1 +-- compiler: ghc +-- with-compiler: +-- with-hc-pkg: +-- scratchdir: +-- program-prefix: +-- program-suffix: +-- library-vanilla: True +-- library-profiling: False +-- shared: False +-- executable-profiling: False +-- optimization: True +-- library-for-ghci: True +-- split-objs: False +-- executable-stripping: True +user-install: False +package-db: ./packages.conf +-- flags: +-- extra-include-dirs: +-- extra-lib-dirs: +-- constraint: +-- cabal-lib-version: +-- preference: +-- documentation: False +-- doc-index-file: $datadir/doc/index.html +-- root-cmd: +-- symlink-bindir: +build-summary: ./logs/build.log +-- build-log: +remote-build-reporting: anonymous +-- username: +-- password: + +install-dirs user + prefix: ./ + -- bindir: $prefix/bin + -- libdir: $prefix/lib + -- libsubdir: $pkgid/$compiler + -- libexecdir: $prefix/libexec + -- datadir: $prefix/share + -- datasubdir: $pkgid + -- docdir: $datadir/doc/$pkgid + -- htmldir: $docdir/html + -- haddockdir: $htmldir + +install-dirs global + prefix: ./ + -- bindir: $prefix/bin + -- libdir: $prefix/lib + -- libsubdir: $pkgid/$compiler + -- libexecdir: $prefix/libexec + -- datadir: $prefix/share + -- datasubdir: $pkgid + -- docdir: $datadir/doc/$pkgid + -- htmldir: $docdir/html + -- haddockdir: $htmldir diff --git a/cabal-dev.cabal b/cabal-dev.cabal new file mode 100644 --- /dev/null +++ b/cabal-dev.cabal @@ -0,0 +1,135 @@ +Name: cabal-dev +Version: 0.7 +Synopsis: Manage sandboxed Haskell build environments + +Description: cabal-dev is a tool for managing development builds of + Haskell projects. It supports maintaining sandboxed + cabal-install repositories, and sandboxed ghc package + databases. + . + By default, it uses a cabal-dev directory under + the current working directory as the sandbox. + . + For most packages, just use @cabal-dev@ instead of + @cabal@, and you will get a sandboxed build that + will not install anything (even automatically installed + dependencies) into the user or global ghc package + databases. + . + If your build depends on patched or unreleased libraries, + you can add them to your sandboxed build environment so + they can be installed by @cabal-dev@ or @cabal@. Just run: + . + > cabal-dev add-source /path/to/source/code + . + @cabal-dev add-source@ also supports importing tarballs + into a local cabal repository. + . + This tool has been tested with GHC 6.8-6.12. + +License: BSD3 +License-file: LICENSE +Author: Josh Hoyt, Jonathan Daughtery, Rogan Creswick +Maintainer: j3h@galois.com, jtd@galois.com, creswick@galois.com +Copyright: 2010 Galois, Inc. +Category: Development +Build-type: Custom +Cabal-version: >=1.2 +Data-Files: + admin/cabal-config.in, + admin/00-index.tar + +Flag no-cabal-dev + Description: Do not build cabal-dev (just build ghc-pkg-6_8-compat). + This is useful for bootstrapping on GHC 6.8. + Default: False + + -- Don't try to flip this flag when looking for a + -- satisfiable configuration for this package + Manual: True + +Flag build-tests + Description: Build and install the test executable + Default: False + Manual: True + +Executable ghc-pkg-6_8-compat + Main-is: GhcPkgCompat.hs + Build-Depends: + base < 5, + Cabal >=1.2 && < 1.11 + + GHC-Options: -Wall + HS-Source-Dirs: src + +Executable cabal-dev-test + Main-is: RunTests.hs + GHC-Options: -Wall + HS-Source-Dirs: src, test + if flag(no-cabal-dev) || !flag(build-tests) + Buildable: False + else + if impl(ghc >= 6.10) + Build-depends: + base >= 4 && < 5 + else + Build-depends: + base >= 3 && < 4 + + Build-depends: + MonadRandom >= 0.1 && < 0.2, + random >= 1 && < 1.1, + test-framework >= 0.3 && < 0.4, + test-framework-hunit >= 0.2, + HUnit >= 1.2 && <2, +-- These dependencies are needed for the cabal-install +-- code that is pulled in automatically by the userhooks + containers >= 0.1 && < 0.4, + network >= 1 && < 3, + array >= 0.1 && < 0.4, + pretty >= 1 && < 1.1 + + if os(windows) + build-depends: Win32 >= 2.1 && < 2.3 + + +Executable cabal-dev + HS-Source-Dirs: src + Main-is: Main.hs + GHC-Options: -Wall + + if flag(no-cabal-dev) + Buildable: False + else + if impl(ghc >= 6.10) + Build-depends: + base >= 4 && < 5 + else + Build-depends: + base >= 3 && < 4 + + Build-depends: + bytestring >= 0.9 && < 0.10, + directory >= 1.0 && < 1.2, + filepath >= 1.1 && < 1.3, + Cabal >= 1.8.0.6 && < 1.11, + HTTP >= 4000.0.9 && < 4000.2, + mtl >= 1.1 && < 2.1, + network >= 2.2 && < 2.4, + pretty >= 1.0 && < 1.1, + process >= 1.0 && < 1.1, + tar >= 0.3 && < 0.4, + zlib >= 0.5 && < 0.6 + + if os(windows) + build-depends: Win32 >= 2.1 && < 2.3 + + Other-modules: + Distribution.Dev.AddSource, + Distribution.Dev.Sandbox, + Distribution.Dev.Command, + Distribution.Dev.Flags, + Distribution.Dev.InvokeCabal, + Distribution.Dev.InstallDependencies, + Distribution.Dev.RewriteCabalConfig, + Distribution.Dev.InitPkgDb diff --git a/src/Distribution/Dev/AddSource.hs b/src/Distribution/Dev/AddSource.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Dev/AddSource.hs @@ -0,0 +1,402 @@ +{- Copyright (c) 2010 Galois, Inc. -} +{-| + +add-source command + +Puts local source packages into a repository readable by cabal-install + +-} +{-# LANGUAGE CPP #-} +module Distribution.Dev.AddSource + ( actions + ) +where + +#ifndef MIN_VERSION_Cabal +#define MIN_VERSION_Cabal(a,b,c) 1 +#endif + +import Control.Applicative ( (<$>), (<*>) ) +import Control.Arrow ( right ) +import Control.Exception ( bracket ) +import Control.Monad ( guard, (<=<), forM_ ) +import Control.Monad.Error ( runErrorT, throwError ) +import Control.Monad.Trans ( liftIO ) +import Data.List ( isPrefixOf ) +import Distribution.PackageDescription ( PackageDescription(buildType), BuildType(Custom) + , packageDescription, package ) +import Distribution.Package ( PackageIdentifier(..) ) +#if MIN_VERSION_Cabal(1,6,0) +import Distribution.PackageDescription.Parse ( ParseResult(ParseOk), readPackageDescription + , parsePackageDescription ) +import Distribution.Package ( PackageName(..) ) +#elif MIN_VERSION_Cabal(1,4,0) +import Distribution.PackageDescription ( ParseResult(ParseOk), readPackageDescription + , parsePackageDescription ) +#else +#error Unsupported Cabal version +#endif +import Distribution.Text ( simpleParse, display ) +import Network.HTTP ( mkRequest, RequestMethod(GET) + , rspBody, simpleHTTP + ) +import Network.URI ( parseURI, uriScheme, URI + , uriPath ) +import System.Cmd ( rawSystem ) +import System.Console.GetOpt ( OptDescr(..) ) +import System.Directory ( getDirectoryContents + , renameFile, copyFile + , getCurrentDirectory + , setCurrentDirectory + , createDirectoryIfMissing + , getTemporaryDirectory + ) +import System.Exit ( ExitCode(..) ) +import System.FilePath ( takeExtension, takeBaseName + , splitDirectories, (<.>), () + , splitExtension + ) +import System.IO ( withBinaryFile, IOMode(..), hClose + , openTempFile, hFlush, hSetBinaryMode + ) +import System.IO.Error ( isDoesNotExistError ) + +import qualified Codec.Archive.Tar as T +import qualified Codec.Archive.Tar.Entry as T +import qualified Codec.Compression.GZip as Z +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 ( unpack ) +import qualified Distribution.Verbosity as V + +import Distribution.Dev.InvokeCabal ( cabalArgs ) +import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) ) +import Distribution.Dev.Flags ( Config, getVerbosity ) +import Distribution.Dev.Sandbox ( resolveSandbox, localRepoPath + , Sandbox, indexTar, indexTarBase + ) + +import Distribution.Simple.Utils ( debug, notice ) + +actions :: CommandActions +actions = CommandActions + { cmdDesc = "Add packages to a local cabal install repository" + , cmdRun = \cfg _ -> addSources cfg + , cmdOpts = [] :: [OptDescr ()] + , cmdPassFlags = False + } + +addSources :: Config -> [String] -> IO CommandResult +addSources _ [] = return $ CommandError "No package locations supplied" +addSources flgs fns = do + sandbox <- resolveSandbox flgs + let v = getVerbosity flgs + debug v $ "Making a cabal repo in " ++ localRepoPath sandbox ++ + " out of " ++ show fns + eArgs <- cabalArgs flgs + case eArgs of + Left err -> return $ CommandError $ "Error getting cabal arguments: " ++ err + Right args -> + do + results <- mapM (processLocalSource v) fns + let errs = [e | Left e <- results] + srcs = [s | Right s <- results] + if not $ null errs + then return $ CommandError $ unlines $ + "Errors finding cabal files:":map (showString " ") errs + else do + let (sources, newEntries) = unzip srcs + res <- readExistingIndex sandbox + case res of + Left err -> return $ + CommandError $ "Error reading existing index: " ++ err + Right existingIndex -> + do let newIndex = mergeIndices existingIndex newEntries + -- Now we have the new index ready and have + -- sanity-checked all of the package locations + -- to be sure that they contain a cabal package + -- (or at least a .cabal file) + -- + -- Now to install the tarballs for the + -- directories: + forM_ sources $ \(src, pkgId, pkgDesc) -> + installTarball flgs sandbox src pkgId pkgDesc args + + -- and now that the tarballs are in place, + -- write out the updated index + writeIndex sandbox newIndex + return CommandOk + +-- |Atomically write an index tarball in the supplied directory +writeIndex :: Sandbox a -- ^The local repository path + -> [T.Entry] -- ^The index entries + -> IO () +writeIndex sandbox ents = + do newIndexName <- withTmpIndex $ \(fn, h) -> do + hSetBinaryMode h True + L.hPut h (T.write ents) + hFlush h + return fn + renameFile newIndexName $ indexTar sandbox + where + pth = localRepoPath sandbox + withTmpIndex = bracket (openTempFile pth indexTarBase) (hClose . snd) + +-- |Merge two lists of tar entries, filtering out the entries from the +-- original list that will be duplicated by the second list of +-- entries +mergeIndices :: [T.Entry] -> [T.Entry] -> [T.Entry] +mergeIndices old new = filter notInNew old ++ new + where + newPaths = map T.entryTarPath new + notInNew e = not $ T.entryTarPath e `elem` newPaths + +-- |Create a tar entry for the package identifier and cabal file contents +toIndexEntry :: PackageIdentifier -> L.ByteString -> Either String T.Entry +toIndexEntry pkgId c = right toEnt $ T.toTarPath False (indexName pkgId) + where + toEnt p = T.fileEntry p c + +-- |Read an existing index tarball from the local repository, if one +-- exists. If the file does not exist, behave as if the index has no +-- entries. +readExistingIndex :: Sandbox a -> IO (Either String [T.Entry]) +readExistingIndex sandbox = + readIndexFile `catch` \e -> + if isDoesNotExistError e + then return $ Right [] + else ioError e + where + readIndexFile = withBinaryFile (indexTar sandbox) ReadMode $ + (forceEntries . T.read <=< L.hGetContents) + forceEntries es = + let step _ l@(Left _) = l + step x (Right xs) = Right (x:xs) + es' = T.foldEntries step (Right []) Left es + in either (const 0) length es' `seq` return es' + + +-- |What kind of package source is this? +data LocalSource = DirPkg FilePath | TarPkg FilePath deriving Show + +-- |Determine if this filename looks like a tarball (otherwise, it +-- assumes that it's a directory and treats it as such) +classifyLocalSource :: String -> Either URI LocalSource +classifyLocalSource fn = + case parseURI fn of + Just u | isHttpUri u && isTarGzUri u -> Left u + _ | isTarball fn -> Right $ TarPkg fn + | otherwise -> Right $ DirPkg fn + where + isHttpUri = (`elem` ["http:", "https:"]) . uriScheme + isTarGzUri = (reverse ".tar.gz" `isPrefixOf`) . reverse . uriPath + +-- |Put the tarball for this package in the local repository +installTarball :: Config + -> Sandbox a -- ^Location of the local repository + -> LocalSource -- ^What kind of package source + -> PackageIdentifier + -> PackageDescription -- ^Package description + -> [String] -- ^Cabal args, computed at the top level + -> IO (Either String ()) +installTarball flgs sandbox src pkgId pkgDesc args = + do createDirectoryIfMissing True $ localRepoPath sandbox repoDir pkgId + case src of + TarPkg fn -> do copyFile fn dest + return $ Right () + DirPkg fn -> do + res <- makeSDist fn + case res of + Left err -> return $ Left err + Right tarFn -> do + renameFile tarFn dest + return $ Right () + where + dest = localRepoPath sandbox tarballName pkgId + makeSDist fn = do + debug (getVerbosity flgs) $ "Running cabal sdist in " ++ fn + bracket getCurrentDirectory setCurrentDirectory $ \_ -> do + setCurrentDirectory fn + -- If the build-type is custom, run 'configure' + -- and invoke the generated setup program. + -- Otherwise, just run plain sdist. We do this to + -- work around + -- http://hackage.haskell.org/trac/hackage/ticket/410 + cabalRes <- case buildType pkgDesc of + Just Custom -> do + -- We run configure without args + -- first to compile the Setup + -- program. We do this to work + -- around a different bug in Cabal + -- (http://hackage.haskell.org/trac/hackage/ticket/731) + rawSystem "cabal" ["configure"] + rawSystem "dist/setup/setup" ["sdist"] + _ -> rawSystem "cabal" ["sdist"] + + case cabalRes of + ExitSuccess -> + do here <- getCurrentDirectory + return $ Right $ here "dist" + display pkgId <.> "tar" <.> "gz" + ExitFailure code -> + return $ Left $ + "cabal sdist failed with " ++ show code + +downloadTarball :: URI -> IO (Either String FilePath) +downloadTarball u = do + tmpLoc <- getTemporaryDirectory + bracket (openTempFile tmpLoc "package-.tar.gz") (hClose . snd) $ \(fn, h) -> + do httpRes <- simpleHTTP $ mkRequest GET u + case httpRes of + Left err -> return $ Left $ show err + Right resp -> + do L.hPut h $ rspBody resp + return $ Right fn + +-- |Extract the index information from the supplied path, either as a +-- tarball or as a local package directory +processLocalSource :: V.Verbosity -> FilePath + -> IO (Either String ((LocalSource, PackageIdentifier, PackageDescription), T.Entry)) +processLocalSource v fn = + runErrorT $ do + let cls = classifyLocalSource fn + src <- case cls of + Left u -> do + liftIO $ notice v $ "Downloading " ++ show u + TarPkg `fmap` eitherErrorIO (downloadTarball u) + Right s -> return s + (pkgId, c, pkgDesc) <- eitherErrorIO $ + case src of + TarPkg x -> processTarball x + DirPkg x -> processDirectory v x + ent <- eitherError $ toIndexEntry pkgId c + return ((src, pkgId, pkgDesc), ent) + where + eitherError = either throwError return + eitherErrorIO = eitherError <=< liftIO + +-- |Extract the index information from a tarball +processTarball :: FilePath + -> IO (Either String (PackageIdentifier, L.ByteString, PackageDescription)) +processTarball fn = + withBinaryFile fn ReadMode $ \h -> + do ents <- T.read . Z.decompress <$> L.hGetContents h + case extractCabalFile ents of + Nothing -> return $ Left "No cabal file found" + + -- Force reading the cabal file before we exit withFile + Just res@(_, bs, _) -> do + forceBS bs + return (Right res) + +#if MIN_VERSION_Cabal(1,6,0) +mkPackageName :: String -> PackageName +mkPackageName = PackageName + +displayPackageName :: PackageName -> String +displayPackageName = display +#elif MIN_VERSION_Cabal(1,4,0) +mkPackageName :: String -> String +mkPackageName = id + +displayPackageName :: String -> String +displayPackageName = id +#else +#error Unsupported cabal version +#endif + +-- |Extract the index information from a directory containing a cabal +-- file +processDirectory :: V.Verbosity -> FilePath + -> IO (Either String (PackageIdentifier, L.ByteString, PackageDescription)) +processDirectory v d = go `catch` \e -> + if expected e + then return $ Left $ show e + else ioError e + where + expected e = any ($ e) [ isDoesNotExistError + ] + + go = do + fns <- getDirectoryContents d + case filter isCabalFile fns of + [c] -> processCabalFile c + [] -> return $ Left "No cabal file found" + _ -> return $ Left "More than one cabal file present" + + processCabalFile c = do + let fn = d c + pkgDesc <- packageDescription <$> + readPackageDescription V.normal fn + let pkgId = package pkgDesc + if mkPackageName (takeBaseName c) == pkgName pkgId + then do + notice v $ "Building source dist at " ++ d ++ " for " ++ display pkgId + cabalFile <- withBinaryFile fn ReadMode $ + forcedBS <=< L.hGetContents + return $ Right (pkgId, cabalFile, pkgDesc) + else + return $ Left $ unlines $ + [ "Package name does not match cabal file name:" + , " filename = " ++ fn + , " package name 1 = " ++ show (mkPackageName (takeBaseName c)) + , " package name 2 = " ++ show (pkgName pkgId) + ] + +-- |Force a lazy ByteString to be read +forceBS :: L.ByteString -> IO () +forceBS bs = L.length bs `seq` return () + +-- |Force a lazy ByteString to be read, and pass it on to the next action +forcedBS :: L.ByteString -> IO L.ByteString +forcedBS bs = forceBS bs >> return bs + +-- |Extract a cabal file from a package tarball +extractCabalFile :: T.Entries -> Maybe (PackageIdentifier, L.ByteString, PackageDescription) +extractCabalFile = T.foldEntries step Nothing (const Nothing) + where + step ent Nothing = (,,) <$> entPackageId ent <*> entBytes ent <*> (parseDesc $ entBytes ent) + step _ ans = ans + + parseDesc bs = do + str <- L8.unpack <$> bs + let result = parsePackageDescription str + case result of + ParseOk _ pkg -> return $ packageDescription pkg + _ -> Nothing + + entPackageId ent = + case splitDirectories $ T.entryPath ent of + [d, f] -> + do i <- simpleParse d + let cabalName = mkPackageName $ takeBaseName f + guard $ isCabalFile f && cabalName == pkgName i + return i + _ -> Nothing + + entBytes ent = case T.entryContent ent of + T.NormalFile x _ -> return x + _ -> Nothing + +-- | Does this filename look like a cabal file? +isCabalFile :: FilePath -> Bool +isCabalFile = (== ".cabal") . takeExtension + +-- |Does this filename look like a gzipped tarball? +isTarball :: FilePath -> Bool +isTarball fn = (ext2, ext1) == (".tar", ".gz") + where + (fn1, ext1) = splitExtension fn + (_, ext2) = splitExtension fn1 + +-- |The path to the .cabal file in the 00-index.tar file +indexName :: PackageIdentifier -> FilePath +indexName pkgId = repoDir pkgId + (displayPackageName (pkgName pkgId) <.> "cabal") + +-- |The path to the tarball in the local repository +tarballName :: PackageIdentifier -> FilePath +tarballName pkgId = repoDir pkgId (display pkgId <.> "tar" <.> "gz") + +repoDir :: PackageIdentifier -> FilePath +repoDir pkgId = displayPackageName (pkgName pkgId) + display (pkgVersion pkgId) diff --git a/src/Distribution/Dev/Command.hs b/src/Distribution/Dev/Command.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Dev/Command.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Distribution.Dev.Command + ( CommandActions(..) + , CommandResult(..) + ) +where + +import System.Console.GetOpt ( OptDescr(..) ) + +import Distribution.Dev.Flags ( Config ) + +data CommandResult = CommandError String | CommandOk + +data CommandActions + = forall a . CommandActions + { cmdDesc :: String + , cmdRun :: Config -> [a] -> [String] -> IO CommandResult + , cmdOpts :: [OptDescr a] + , cmdPassFlags :: Bool + } diff --git a/src/Distribution/Dev/Flags.hs b/src/Distribution/Dev/Flags.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Dev/Flags.hs @@ -0,0 +1,129 @@ +{- Copyright (c) 2010 Galois, Inc. -} +{-# LANGUAGE CPP #-} +module Distribution.Dev.Flags + ( GlobalFlag(..) + + , Config + , getCabalConfig + , getSandbox + , sandboxSpecified + , getVerbosity + , fromFlags + + , globalOpts + , parseGlobalFlags + , helpRequested + , getOpt'' + ) +where + +import Control.Monad ( mplus ) +import Data.Monoid ( Monoid(..) ) +import Data.List ( intercalate ) +import Data.Maybe ( fromMaybe, isJust ) +import Data.Foldable ( foldMap ) +import System.FilePath ( () ) +import Distribution.ReadE ( runReadE ) +import Distribution.Verbosity ( Verbosity, normal, verbose, flagToVerbosity ) +import Paths_cabal_dev ( getDataFileName ) +import System.Console.GetOpt ( OptDescr(..), ArgOrder(..), ArgDescr(..) + , getOpt', getOpt + ) + +data GlobalFlag = Help + | Verbose (Maybe String) + | Sandbox FilePath + | CabalConf FilePath + | Version Bool + deriving (Eq, Show) + +globalOpts :: [OptDescr GlobalFlag] +globalOpts = [ Option "h?" ["help"] (NoArg Help) "Show help text" + , Option "s" ["sandbox"] (ReqArg Sandbox "DIR") + "The location of the development cabal sandbox (default: ./cabal-dev)" + , Option "c" ["config"] (ReqArg CabalConf "PATH") + "The location of the cabal-install config file (default: use included)" + , Option "v" ["verbose"] (OptArg Verbose "LEVEL") + "Verbosity level: 0 (silent) - 3 (deafening)" + , Option "" ["version"] (NoArg (Version False)) + "Show the version of this program" + , Option "" ["numeric-version"] (NoArg (Version True)) + "Show a machine-readable version number" + ] + +getOpt'' :: [OptDescr a] -> [String] -> ([a], [String], [String]) +getOpt'' opts args = + case break (== "--") args of + (_, []) -> + -- Mixed args (make a best guess about which ones are ours + -- and attempt to preserve the others. This gets especially + -- confused for unknown short options that take arguments. + -- (e.g. cabal install -ftest) + let (flgs, args', unknown, errs) = getOpt' Permute opts args + unusedArgs = args' ++ unknown + -- Attempt to get the arguments back into the order that they + -- were passed in, so for example, if there is an argument + -- --foo -o xxx -bar, we keep the xxx as a potential argument + -- to -o + unprocessed = [arg | arg <- args, arg `elem` unusedArgs] + in (flgs, unprocessed, errs) + + (ourArgs, "--":theirArgs) -> + let (flgs, extraArgs, errs) = getOpt RequireOrder opts ourArgs + errs' | null extraArgs = errs + | otherwise = + let msg = "Unknown arguments for cabal-dev: " ++ + intercalate " " extraArgs + in (msg:errs) + in (flgs, theirArgs, errs') + + impossible -> error $ + "Impossible outcome from break: " ++ show impossible + +parseGlobalFlags :: [String] -> ([GlobalFlag], [String], [String]) +parseGlobalFlags = getOpt'' globalOpts + +helpRequested :: [GlobalFlag] -> Bool +helpRequested = (Help `elem`) + +getCabalConfig :: Config -> IO FilePath +getCabalConfig = maybe defaultFileName return . cfgCabalConfig + where + defaultFileName = getDataFileName $ "admin" "cabal-config.in" + +getVerbosity :: Config -> Verbosity +getVerbosity = fromMaybe normal . cfgVerbosity + +defaultSandbox :: FilePath +defaultSandbox = "cabal-dev" + +getSandbox :: Config -> FilePath +getSandbox = fromMaybe defaultSandbox . cfgSandbox + +sandboxSpecified :: Config -> Bool +sandboxSpecified = isJust . cfgSandbox + +data Config = Config { cfgVerbosity :: Maybe Verbosity + , cfgCabalConfig :: Maybe FilePath + , cfgSandbox :: Maybe FilePath + } + +instance Monoid Config where + mempty = Config Nothing Nothing Nothing + mappend (Config v1 c1 s1) (Config v2 c2 s2) = + Config (v2 `mplus` v1) (c2 `mplus` c1) (s2 `mplus` s1) + +fromFlag :: GlobalFlag -> Config +fromFlag (CabalConf p) = mempty { cfgCabalConfig = Just p } +fromFlag (Sandbox s) = mempty { cfgSandbox = Just s } +fromFlag (Verbose s) = mempty { cfgVerbosity = v } + where + v = case runReadE flagToVerbosity `fmap` s of + Nothing -> Just verbose + Just (Right x) -> Just x + Just _ -> Nothing -- XXX: we are ignoring + -- verbosity parse errors +fromFlag _ = mempty + +fromFlags :: [GlobalFlag] -> Config +fromFlags = foldMap fromFlag diff --git a/src/Distribution/Dev/InitPkgDb.hs b/src/Distribution/Dev/InitPkgDb.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Dev/InitPkgDb.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE CPP #-} +module Distribution.Dev.InitPkgDb + ( initPkgDb + ) +where + + +import Control.Monad ( unless ) +import Distribution.Simple.Program ( ghcPkgProgram, requireProgram + , programVersion, ConfiguredProgram + , programLocation, locationPath + ) +import Distribution.Version ( Version(..) ) +import Distribution.Verbosity ( Verbosity ) +import Distribution.Simple.Utils ( info ) + +import Distribution.Simple.Program ( rawSystemProgram, emptyProgramConfiguration ) +import Distribution.Text ( display ) + +import System.Directory ( doesFileExist, doesDirectoryExist ) + +import Distribution.Dev.Sandbox ( Sandbox, pkgConf, PackageDbType(..) + , UnknownVersion, KnownVersion, setVersion ) + +-- |Initialize a package database. +-- +-- XXX: This is GHC-only. Cabal supports other compilers, so we should, too. +-- +-- XXX: If a compilation happens in a sandbox for that was used for a +-- GHC version with a different package config type, this function +-- will just fail. Ideally, we'd have different package DBs for +-- different GHC versions, but the cabal-install config file just sets +-- one location. We'd have to have the GHC version before writing the +-- cabal config file. +initPkgDb :: Verbosity -> Sandbox UnknownVersion -> IO (Sandbox KnownVersion) +initPkgDb v s = do + let require p = requireProgram v p emptyProgramConfiguration + run = rawSystemProgram + + ghcPkg <- fst `fmap` require ghcPkgProgram + let (ver, typ) = ghcPackageDbType ghcPkg + s' = setVersion s typ ver + pth = pkgConf s' + + case typ of + GHC_6_12_Db -> do + e <- doesDirectoryExist pth + unless e $ run v ghcPkg ["init", pth] + _ -> do + e <- doesFileExist pth + unless e $ writeFile pth "[]" + + info v $ "Using ghc-pkg " ++ display ver ++ + case typ of + GHC_6_8_Db _ -> " wrapper" + _ -> "" + + return s' + +ghcPackageDbType :: ConfiguredProgram -> (Version, PackageDbType) +ghcPackageDbType p = + case res of + Nothing -> error "Unknown ghc version!" + Just v -> v + where + res = do + v <- programVersion p + let typ | v < Version [6, 10] [] = GHC_6_8_Db $ locationPath $ + programLocation p + | v < Version [6, 12] [] = GHC_6_10_Db + | otherwise = GHC_6_12_Db + return (v, typ) diff --git a/src/Distribution/Dev/InstallDependencies.hs b/src/Distribution/Dev/InstallDependencies.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Dev/InstallDependencies.hs @@ -0,0 +1,58 @@ +module Distribution.Dev.InstallDependencies + ( actions ) +where + +import System.Console.GetOpt ( OptDescr(..) ) +import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) ) +import Distribution.Dev.Flags ( Config, getVerbosity ) +import Distribution.Dev.Sandbox ( resolveSandbox ) +import Distribution.Dev.InitPkgDb ( initPkgDb ) +import Distribution.Dev.InvokeCabal ( setup, cabalProgram ) +import Distribution.Simple.Program ( requireProgram + , getProgramOutput + , runProgram + ) +import Distribution.Simple.Program.Db ( emptyProgramDb ) +import Distribution.Simple.Utils ( notice ) + +actions :: CommandActions +actions = CommandActions + { cmdDesc = "Install the dependencies for this package" + , cmdRun = \cfg _ args -> installDependencies cfg args + , cmdOpts = [] :: [OptDescr ()] + , cmdPassFlags = True + } + +installDependencies :: Config -> [String] -> IO CommandResult +installDependencies flgs pkgNames = do + let v = getVerbosity flgs + s <- initPkgDb v =<< resolveSandbox flgs + setupRes <- setup s flgs + case setupRes of + Left err -> return $ CommandError err + Right args -> + do + (cabal, _) <- requireProgram v cabalProgram emptyProgramDb + out <- getProgramOutput v cabal $ concat + [ args + , ["install", "--dry-run", "--verbose=1"] + , pkgNames + ] + let -- Drop the lines that say: + -- Resolving dependencies... + -- In order, the following [...] + pkgIdStrs = drop 2 $ lines out + + -- We take the init if no pkgNames were supplied because + -- that means we're working on the cabal file in the + -- current directory. + deps = case pkgNames of + [] | not $ null pkgIdStrs -> init pkgIdStrs + _ -> pkgIdStrs + + case deps of + [] -> notice v "No dependencies need to be installed" + _ -> do notice v $ "Installing dependencies: " ++ unwords deps + runProgram v cabal $ args ++ ("install":deps) + + return CommandOk diff --git a/src/Distribution/Dev/InvokeCabal.hs b/src/Distribution/Dev/InvokeCabal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Dev/InvokeCabal.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP #-} +module Distribution.Dev.InvokeCabal + ( actions + , setup + , extraArgs + , cabalProgram + , cabalArgs + ) +where + +import Distribution.Version ( Version(..) ) +import Distribution.Verbosity ( Verbosity, showForCabal ) +import Distribution.Simple.Program ( Program( programFindVersion + , programFindLocation + ) + , emptyProgramConfiguration + , findProgramVersion + , locationPath + , programLocation + , programVersion + , requireProgram + , runProgram + , simpleProgram + ) +import Distribution.Simple.Utils ( withUTF8FileContents, writeUTF8File + , debug, cabalVersion ) +import Distribution.Text ( display ) +import System.Console.GetOpt ( OptDescr ) + +import Distribution.Dev.Command ( CommandActions(..) + , CommandResult(..) + ) +import Distribution.Dev.Flags ( Config, getCabalConfig + , getVerbosity + ) +import Distribution.Dev.InitPkgDb ( initPkgDb ) +import qualified Distribution.Dev.RewriteCabalConfig as R +import Distribution.Dev.Sandbox ( resolveSandbox + , cabalConf + , Sandbox + , KnownVersion + , PackageDbType(..) + , getVersion + , pkgConf + , sandbox + ) +import System.Directory ( canonicalizePath, getAppUserDataDirectory ) + +actions :: String -> CommandActions +actions act = CommandActions + { cmdDesc = "Invoke cabal-install with the development configuration" + , cmdRun = \flgs _ args -> invokeCabal flgs (act:args) + , cmdOpts = [] :: [OptDescr ()] + , cmdPassFlags = True + } + +invokeCabal :: Config -> [String] -> IO CommandResult +invokeCabal flgs args = do + let v = getVerbosity flgs + s <- initPkgDb v =<< resolveSandbox flgs + res <- setup s flgs + case res of + Left err -> return $ CommandError err + Right args' -> do + invokeCabalCfg v $ args' ++ args + return CommandOk + +cabalArgs :: Config -> IO (Either String [String]) +cabalArgs flgs = do + let v = getVerbosity flgs + s <- initPkgDb v =<< resolveSandbox flgs + setup s flgs + +setup :: Sandbox KnownVersion-> Config -> IO (Either String [String]) +setup s flgs = do + let v = getVerbosity flgs + cfgIn <- getCabalConfig flgs + let cfgOut = cabalConf s + cabalHome <- getAppUserDataDirectory "cabal" + withUTF8FileContents cfgIn $ \cIn -> + do cfgRes <- R.rewriteCabalConfig (R.Rewrite cabalHome (sandbox s) (pkgConf s)) cIn + case cfgRes of + Left err -> return $ Left $ + "Error processing cabal config file " ++ cfgIn ++ ": " ++ err + Right cOut -> do + writeUTF8File cfgOut cOut + args <- extraArgs v cfgOut (getVersion s) + return $ Right args + +extraArgs :: Verbosity -> FilePath -> PackageDbType -> IO [String] +extraArgs v cfg pdb = + do pdbArgs <- getPdbArgs + return $ [cfgFileArg, verbosityArg] ++ pdbArgs + where + longArg s = showString "--" . showString s . ('=':) + cfgFileArg = longArg "config-file" cfg + verbosityArg = longArg "verbose" $ showForCabal v + withGhcPkg = longArg "with-ghc-pkg" + getPdbArgs = + case pdb of + (GHC_6_8_Db loc) | needsGHC68Compat -> do + -- Make Cabal call the wrapper that removes the + -- bad argument to ghc-pkg 6.8 + debug v $ "Using GHC 6.8 compatibility wrapper for Cabal shortcoming" + (ghcPkgCompat, _) <- + requireProgram v ghcPkgCompatProgram emptyProgramConfiguration + return $ [ longArg "ghc-pkg-options" $ withGhcPkg loc + , withGhcPkg $ locationPath $ + programLocation ghcPkgCompat + ] + _ -> return [] + +-- XXX: this is very imprecise. Right now, we require a specific +-- version of Cabal, so this is ok (and is equivalent to True) +needsGHC68Compat :: Bool +needsGHC68Compat = cabalVersion < Version [1, 9] [] + +ghcPkgCompatProgram :: Program +ghcPkgCompatProgram = p { programFindLocation = + \v -> do + res <- programFindLocation p v + case res of + Nothing -> return Nothing + Just loc -> Just `fmap` canonicalizePath loc + } + where + p = simpleProgram "ghc-pkg-6_8-compat" + +cabalProgram :: Program +cabalProgram = + (simpleProgram "cabal") { programFindVersion = + findProgramVersion "--numeric-version" id + } + +invokeCabalCfg :: Verbosity -> [String] -> IO () +invokeCabalCfg v args = do + (cabal, _) <- requireProgram v cabalProgram emptyProgramConfiguration + debug v $ concat [ "Using cabal-install " + , maybe "(unknown version)" display $ programVersion cabal + , " at " + , show (programLocation cabal) + ] + runProgram v cabal args diff --git a/src/Distribution/Dev/RewriteCabalConfig.hs b/src/Distribution/Dev/RewriteCabalConfig.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Dev/RewriteCabalConfig.hs @@ -0,0 +1,153 @@ +{- Copyright (c) 2010 Galois, Inc. -} +{-| + +Rewrite the paths of a cabal-install config file, canonicalizing them +relative to the current path, supporting limited tilde expansion +(tilde expansion for the current user only) + +This module is written so that it will work out-of-the-box with GHC >= +6.8 && < 6.13 with no other packages installed. + +-} +module Distribution.Dev.RewriteCabalConfig + ( rewriteCabalConfig + , Rewrite(..) + ) +where + +import Data.Maybe ( fromMaybe ) +import Control.Monad ( liftM ) +import Distribution.ParseUtils ( readFields, ParseResult(..), Field(..) ) +import Text.PrettyPrint.HughesPJ + +data Rewrite = Rewrite { homeDir :: FilePath + , sandboxDir :: FilePath + , packageDb :: FilePath + } + +-- |Rewrite a cabal-install config file so that all paths are made +-- absolute and canonical. +rewriteCabalConfig :: Rewrite -> String -> IO (Either String String) +rewriteCabalConfig r = + rewriteConfig (expandCabalConfig (homeDir r) (sandboxDir r)) + (setPackageDb $ packageDb r) + +-- |Given an expansion configuration, read the input config file and +-- write the expansion into the output config file +rewriteConfig :: Expand IO -> ([Field] -> [Field]) -> String + -> IO (Either String String) +rewriteConfig expand proc s = + case readFields s of + ParseFailed err -> return $ Left $ show err + ParseOk _ fs -> + (Right . show . ppTopLevel . proc) `fmap` rewriteTopLevel expand fs + +setPackageDb :: FilePath -> [Field] -> [Field] +setPackageDb pkgDb = (F 0 "package-db" pkgDb:) . filter (not . isPackageDb) + where + isPackageDb (F _ "package-db" _) = True + isPackageDb _ = False + +rewriteTopLevel :: Monad m => Expand m -> [Field] -> m [Field] +rewriteTopLevel = mapM . rewriteField + +rewriteField :: Monad m => Expand m -> Field -> m Field +rewriteField expand field = + case field of + F l name val -> F l name `liftM` rewriteLeaf name val + Section l name key fs -> Section l name key `liftM` + rewriteSection name fs + _ -> error $ "Only top-level fields and sections \ + \supported. Not: " ++ show field + where + rewriteLeaf name val + | name `elem` eLeaves expand = eExpand expand val + | otherwise = return val + + rewriteSection s = rewriteTopLevel $ + fromMaybe don'tExpand $ + lookup s $ eSections expand + +-------------------------------------------------- +-- Output formatting + +ppField :: Field -> Doc +ppField (F _ k v) = text k <> colon <+> text v +ppField (Section _ k v fs) = (text k <+> text v) $+$ + nest 2 (vcat $ map ppField fs) +ppField f = error $ "Pretty printing not implemented: " ++ show f + +ppTopLevel :: [Field] -> Doc +ppTopLevel = vcat . map ppField + +-------------------------------------------------- +-- Expanding fields + +data Expand m = Expand { eExpand :: String -> m String + , eLeaves :: [String] + , eSections :: [(String, Expand m)] + } + +-- |Replace a tilde as an initial path segment with a path. +expandTilde :: FilePath -> String -> String +expandTilde home s = case break (== '/') s of + ("~", rest) -> home ++ rest + _ -> s + +-- |Replace a tilde as an initial path segment with a path. +expandDot :: FilePath -> String -> String +expandDot sandbox s = case break (== '/') s of + (".", rest) -> sandbox ++ rest + _ -> s + +-- |Identity expansion +don'tExpand :: Monad m => Expand m +don'tExpand = Expand return [] [] + +-- This is the part that's specific to the cabal-install config file: +-- These are the parts of the config file that are paths into the +-- local filesystem. Ideally, we'd use the cabal-install Config module +-- and operate on the datatype instead of the raw config file, but +-- that's internal to the cabal-install config file, so we use this +-- ad-hoc approach instead. +-- +-- If the cabal-install config file changes, or if this list is not +-- complete, this code will have to be updated. +expandCabalConfig :: FilePath -> FilePath -> Expand IO +expandCabalConfig home sandbox = + Expand { eExpand = ePath + , eLeaves = [ "remote-repo-cache" + , "local-repo" + , "with-compiler" + , "with-hc-pkg" + , "scratchdir" + , "package-db" + , "extra-include-dirs" + , "extra-lib-dirs" + , "doc-index-file" + , "root-cmd" + , "symlink-bindir" + , "build-summary" + , "build-log" + ] + , eSections = [("install-dirs", expandInstallDirs)] + } + where + expandInstallDirs = + Expand { eExpand = fmap show . ePath + , eLeaves = + [ "prefix" + , "bindir" + , "libdir" + , "libsubdir" + , "libexecdir" + , "datadir" + , "datasubdir" + , "docdir" + , "htmldir" + , "haddockdir" + ] + , eSections = [] + } + + ePath = return . expandDot sandbox . expandTilde home diff --git a/src/Distribution/Dev/Sandbox.hs b/src/Distribution/Dev/Sandbox.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Dev/Sandbox.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP, GADTs, EmptyDataDecls #-} +module Distribution.Dev.Sandbox + ( KnownVersion + , PackageDbType(..) + , Sandbox + , UnknownVersion + , cabalConf + , getVersion + , indexTar + , indexTarBase + , localRepoPath + , newSandbox + , pkgConf + , resolveSandbox + , sandbox + , setVersion + ) +where + +import Control.Monad ( unless ) +import Data.Version ( Version, showVersion ) +import Distribution.Simple.Utils ( debug ) +import Distribution.Verbosity ( Verbosity ) +import System.Directory ( canonicalizePath, createDirectoryIfMissing + , doesFileExist, copyFile ) +import System.FilePath ( () ) + +#ifdef mingw32_HOST_OS +import System.IO ( hPutStrLn, stderr ) +import System.Win32.Types ( getLastError ) +#endif + +import qualified Distribution.Dev.Flags as F + ( getVerbosity, Config, getSandbox, sandboxSpecified ) + +import Paths_cabal_dev ( getDataFileName ) + +-- A sandbox directory that we may or may not know what kind of +-- package format it uses +data UnknownVersion +data KnownVersion + +data Sandbox a where + UnknownVersion :: FilePath -> Sandbox UnknownVersion + KnownVersion :: FilePath -> PackageDbType -> Version -> Sandbox KnownVersion + +data PackageDbType = GHC_6_8_Db FilePath | GHC_6_10_Db | GHC_6_12_Db + +-- NOTE: GHC < 6.12: compilation warnings about non-exhaustive pattern +-- matches are spurious (we'd get a type error if we tried to make +-- them complete!) +setVersion :: Sandbox UnknownVersion -> PackageDbType -> Version -> Sandbox KnownVersion +setVersion (UnknownVersion p) v ty = KnownVersion p v ty + +getVersion :: Sandbox KnownVersion -> PackageDbType +getVersion (KnownVersion _ db _) = db + +sandbox :: Sandbox a -> FilePath +sandbox (UnknownVersion p) = p +sandbox (KnownVersion p _ _) = p + +sPath :: FilePath -> Sandbox a -> FilePath +sPath p s = sandbox s p + +localRepoPath :: Sandbox a -> FilePath +localRepoPath = sPath "packages" + +pkgConf :: Sandbox KnownVersion -> FilePath +pkgConf s@(KnownVersion _ _ v) = sPath packageDbName s + where + packageDbName = "packages-" ++ showVersion v ++ ".conf" + +cabalConf :: Sandbox a -> FilePath +cabalConf = sPath "cabal.config" + +newSandbox :: Verbosity -> FilePath -> IO (Sandbox UnknownVersion) +newSandbox v relSandboxDir = do + sandboxDir <- canonicalizePath relSandboxDir + debug v $ "Using " ++ sandboxDir ++ " as the cabal-dev sandbox" + vista32Workaround_createDirectoryIfMissing True sandboxDir + let sb = UnknownVersion sandboxDir + debug v $ "Creating local repo " ++ localRepoPath sb + vista32Workaround_createDirectoryIfMissing True $ localRepoPath sb + extant <- doesFileExist (indexTar sb) + unless extant $ do + emptyIdxFile <- getDataFileName $ "admin" indexTarBase + copyFile emptyIdxFile (indexTar sb) + return sb + +-- | Ugly hack to try and get around a bug with +-- createDirectoryIfMissing that only occurs on 32-bit windows. +vista32Workaround_createDirectoryIfMissing :: Bool -> FilePath -> IO () +vista32Workaround_createDirectoryIfMissing b fp = +#ifdef mingw32_HOST_OS + createDirectoryIfMissing b fp `catch` \e -> do + erCode <- getLastError + case erCode of + 1006 -> hPutStrLn stderr "Directory already exists--error swallowed" + _ -> ioError e +#else + createDirectoryIfMissing b fp +#endif + +resolveSandbox :: F.Config -> IO (Sandbox UnknownVersion) +resolveSandbox cfg = do + let v = F.getVerbosity cfg + relSandbox = F.getSandbox cfg + unless (F.sandboxSpecified cfg) $ + debug v $ "No sandbox specified. Using " ++ relSandbox + newSandbox v relSandbox + +-- |The name of the cabal-install package index +indexTarBase :: FilePath +indexTarBase = "00-index.tar" + +indexTar :: Sandbox a -> FilePath +indexTar sb = localRepoPath sb indexTarBase diff --git a/src/GhcPkgCompat.hs b/src/GhcPkgCompat.hs new file mode 100644 --- /dev/null +++ b/src/GhcPkgCompat.hs @@ -0,0 +1,67 @@ +{- + +This program is a hack that munges the invocation of ghc-pkg for +ghc-6.8 by cabal-1.8 so that it does not alter the global or user +package databases. + +It is intended to be invoked by cabal as instructed by cabal-dev. + +The bug that this program works around is not present in the cabal-1.9 +development branch, and the bug only affects ghc-6.8 or possibly +older. This program has been tested with GHC 6.8.3. + +It builds with at least GHC 6.8-6.12 and Cabal 1.4-1.8, so that it's +available for use with other sandboxes. + +-} +module Main + ( main + ) +where + +import Distribution.Verbosity ( silent ) +import Distribution.Simple.Utils ( rawSystemExit ) + +import Control.Monad ( msum ) +import Data.Maybe ( fromMaybe, isJust ) +import System.Environment ( getArgs ) + +dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a]) +dropCommonPrefix (a:as) (b:bs) | a == b = dropCommonPrefix as bs +dropCommonPrefix as bs = (as, bs) + +matchPrefix :: Eq a => [a] -> [a] -> Maybe [a] +matchPrefix pfx s = case dropCommonPrefix pfx s of + ([], s') -> Just s' + _ -> Nothing + +ghcPkgExe :: [String] -> FilePath +ghcPkgExe = fromMaybe "ghc-pkg" . msum . map ghcPkgArg + +ghcPkgArg :: String -> Maybe FilePath +ghcPkgArg = matchPrefix "--with-ghc-pkg=" + +isGhcPkgArg :: String -> Bool +isGhcPkgArg = isJust . ghcPkgArg + +isNoUserPackage :: String -> Bool +isNoUserPackage = (== "--no-user-package-conf") + +isPackageConf :: String -> Bool +isPackageConf = isJust . matchPrefix "--package-conf=" + +shouldDrop :: String -> Bool +shouldDrop s = isGhcPkgArg s || isNoUserPackage s + +fixPackageDbSpec :: [String] -> [String] +fixPackageDbSpec args + | any isPackageConf args = filter (not . (`elem` ["--global", "--user"])) args + | otherwise = args + +main :: IO () +main = do + args <- getArgs + let ghcPkg = ghcPkgExe args + ghcPkgArgs = fixPackageDbSpec $ filter (not . shouldDrop) args + v = silent + rawSystemExit v ghcPkg ghcPkgArgs diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,140 @@ +{- Copyright (c) 2010 Galois, Inc -} +module Main + ( main ) +where + +import Data.Maybe ( listToMaybe ) +import Data.Version ( showVersion ) +import Control.Monad ( unless ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Environment ( getArgs, getProgName ) +import System.Console.GetOpt ( usageInfo, getOpt, ArgOrder(Permute) ) +import Distribution.Simple.Utils ( cabalVersion, debug ) +import Distribution.Text ( display ) + +import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) ) +import Distribution.Dev.Flags ( parseGlobalFlags, helpRequested, globalOpts + , GlobalFlag(Version), getOpt'', fromFlags + , getVerbosity, Config + ) +import qualified Distribution.Dev.AddSource as AddSource +import qualified Distribution.Dev.InvokeCabal as InvokeCabal +import qualified Distribution.Dev.InstallDependencies as InstallDeps +import Paths_cabal_dev ( version ) + +allCommands :: [(String, CommandActions)] +allCommands = [ ("add-source", AddSource.actions) + , ("install-deps", InstallDeps.actions) + , cabal "build" + , cabal "clean" + , cabal "configure" + , cabal "copy" + , cabal "fetch" + , cabal "haddock" + , cabal "info" + , cabal "init" + , cabal "install" + , cabal "list" + , cabal "register" + , cabal "unpack" + , cabal "update" + , cabal "hscolour" + , cabal "sdist" + ] + where + cabal s = (s, InvokeCabal.actions s) + +printVersion :: IO () +printVersion = do + putStr versionString + exitWith ExitSuccess + +versionString :: String +versionString = unlines $ + [ "cabal-dev " ++ showVersion version + , "built with Cabal " ++ display cabalVersion + ] + +printNumericVersion :: IO () +printNumericVersion = do + putStrLn $ showVersion version + exitWith ExitSuccess + +main :: IO () +main = do + (globalFlags, args, errs) <- parseGlobalFlags `fmap` getArgs + unless (null errs) $ do + mapM_ putStrLn errs + putStr =<< globalUsage + exitWith (ExitFailure 1) + + case [f|(Version f) <- globalFlags] of + (True:_) -> printNumericVersion + (False:_) -> printVersion + [] -> return () + + let cfg = fromFlags globalFlags + debug (getVerbosity cfg) versionString + + case args of + (name:args') -> + case nameCmd name of + Just cmdAct | helpRequested globalFlags -> + do putStrLn $ cmdDesc cmdAct + putStr =<< globalUsage + exitWith ExitSuccess + | otherwise -> runCmd cmdAct cfg args' + + Nothing -> do putStrLn $ "Unknown command: " ++ show name + putStr =<< globalUsage + exitWith (ExitFailure 1) + _ | helpRequested globalFlags -> do + putStr =<< globalUsage + exitWith ExitSuccess + | otherwise -> do + putStrLn "Missing command name" + putStr =<< globalUsage + exitWith (ExitFailure 1) + +globalUsage :: IO String +globalUsage = do + progName <- getProgName + let preamble = + unlines $ + [ "" + , "Usage: " ++ progName ++ " " + , "" + , "Where is one of:" + ] ++ map (" " ++) allCommandNames ++ + [ "" + , "Options:" + ] + return $ usageInfo preamble globalOpts + +allCommandNames :: [String] +allCommandNames = map fst allCommands + +nameCmd :: String -> Maybe CommandActions +nameCmd s = listToMaybe [a | (n, a) <- allCommands, n == s] + +runCmd :: CommandActions -> Config -> [String] -> IO () +runCmd cmdAct cfg args = + do res <- run + case res of + CommandOk -> exitWith ExitSuccess + CommandError msg -> showError [msg] + where + showError msgs = do + putStr $ unlines $ "FAILED:":msgs ++ [replicate 50 '-', cmdDesc cmdAct] + putStr =<< globalUsage + exitWith (ExitFailure 1) + + run = case cmdAct of + (CommandActions _ r o passFlags) -> + let (cmdFlags, cmdArgs, cmdErrs) = + if passFlags + then getOpt'' o args + else getOpt Permute o args + in if null cmdErrs + then r cfg cmdFlags cmdArgs + else showError cmdErrs diff --git a/test/RunTests.hs b/test/RunTests.hs new file mode 100644 --- /dev/null +++ b/test/RunTests.hs @@ -0,0 +1,469 @@ +import qualified Codec.Archive.Tar as Tar +import qualified Data.ByteString.Lazy.Char8 as L +import Control.Applicative ( (<$>), (<*>), pure ) +import Control.Monad ( replicateM, when ) +import Control.Monad.Random ( Rand, getRandomR, evalRandIO ) +import Data.Char ( isAscii, isAlphaNum, isLetter ) +import Data.List ( intercalate ) +import Data.Monoid ( mempty ) +import Distribution.Package ( PackageIdentifier(..), PackageName(..) + , packageId, packageName ) +import Distribution.Simple.GHC ( getInstalledPackages ) +import Distribution.Simple.Compiler ( PackageDB(..) + ) +import Distribution.Simple.Program ( configureAllKnownPrograms + , addKnownPrograms + , emptyProgramConfiguration + , ghcPkgProgram + , ghcProgram + , ProgramConfiguration + ) +import Distribution.Simple.PackageIndex ( lookupSourcePackageId, allPackages + , SearchResult(..), searchByName + , PackageIndex + ) +import Distribution.InstalledPackageInfo ( installedPackageId ) +import Distribution.Simple.Utils ( withTempDirectory, info ) +import Distribution.Text ( simpleParse, display ) +import Distribution.Verbosity ( normal, Verbosity, showForCabal, verbose ) +import Distribution.Version ( Version(..) ) +import Distribution.Dev.InitPkgDb ( initPkgDb ) +import Distribution.Dev.Sandbox ( newSandbox, pkgConf, Sandbox, KnownVersion, sandbox, indexTar ) +import System.IO ( withBinaryFile, IOMode(ReadMode) ) +import System.Cmd ( rawSystem ) +import System.Process ( readProcessWithExitCode ) +import System.Directory ( getTemporaryDirectory, createDirectory ) +import System.Environment ( getArgs ) +import System.Exit ( ExitCode(ExitSuccess) ) +import System.FilePath ( (), (<.>), takeExtension ) +import System.Random ( RandomGen ) +import Test.Framework ( defaultMainWithArgs, Test, testGroup ) +import Test.Framework.Providers.HUnit ( testCase ) +import qualified Test.HUnit as HUnit + +import Distribution.Client.Config -- ( parseConfig ) +import Distribution.Client.Setup ( GlobalFlags(..) ) +import Distribution.Simple.InstallDirs +import Distribution.Simple.Setup +import Distribution.ParseUtils +import Data.Function ( on ) + + +tests :: FilePath -> [Test] +tests p = + [ testGroup "Basic invocation tests" $ testBasicInvocation p + , testGroup "Sandboxed" $ + [ testCase "add-source stays sandboxed (no-space dir)" $ + addSourceStaysSandboxed normal p "fake-package." + , testCase "add-source stays sandboxed (dir with spaces)" $ + addSourceStaysSandboxed normal p "fake package." + , testCase "Builds ok regardless of the state of the logs directory" $ + assertLogLocationOk normal p + , testCase "Index tar files contain all contents" $ + assertTarFileOk normal p + ] + , testGroup "Parsing and serializing" $ + [ testCase "simple round-trip test" $ + assertRoundTrip + + -- , testCase "sample echo test" $ + -- configEcho + ] + ] + +testBasicInvocation :: FilePath -> [Test] +testBasicInvocation p = + [ testCase "--help exists with success" $ + assertExitsSuccess p ["--help"] + + , testCase "--version exists with success" $ + assertExitsSuccess p ["--version"] + + , testCase "--numeric-version has parseable output" $ + assertProgramOutput checkNumericVersion p ["--numeric-version"] + + , testCase "exits with failure when no arguments are supplied" $ + assertExitsFailure p [] + ] + +main :: IO () +main = do + args <- getArgs + + -- The first argument is the cabal-dev executable. The remaining + -- arguments are passed directly to test-framework + let (cabalDev, testFrameworkArgs) = + case args of + (x:xs) -> (x, xs) + [] -> ("cabal-dev", []) + + defaultMainWithArgs (tests cabalDev) testFrameworkArgs + +-- |Test that parsing and serializing a cabal-install SavedConfig with +-- spaces in the paths preserves the spaces properly. +-- +-- This tests only a select few of the fields and leaves the rest +-- empty. In practice, this has proven to be adequate. +-- +-- This is really just testing that cabal-install is capable of +-- handling these fields. We have baked in knowledge of the syntax +-- that these fields need into RewriteCabalConfig. Ideally, +-- RewriteCabalConfig would read/write the data structure using the +-- code from cabal-install. We haven't done that because pulling in +-- all of the code from cabal-install into a production build is +-- pretty hackish. I think that cabal-dev ought to be a fork or +-- alternate build of cabal-install. +-- +-- Note that this test is the whole reason that we have the custom +-- build type. +assertRoundTrip :: HUnit.Assertion +assertRoundTrip = + do parsed <- case parseConfig mempty $ showConfig configWithSpaces of + ParseFailed err -> fail $ "Parse failed: " ++ show err + ParseOk _ val -> return val + + let check msg f = + (HUnit.assertEqual msg `on` f) parsed configWithSpaces + + check "globalLocalRepos" (globalLocalRepos . savedGlobalFlags) + check "cache" (globalCacheDir . savedGlobalFlags) + check "prefix" (show . prefix . savedUserInstallDirs) + check "bindir" (show . bindir . savedUserInstallDirs) + check "packageDB" (configPackageDB . savedConfigureFlags) + where + configWithSpaces = + mempty { savedGlobalFlags = + mempty { globalLocalRepos = [pfx "repos"] + , globalCacheDir = toFlag $ pfx "cache" + } + , savedUserInstallDirs = + mempty { prefix = toFlag $ toPathTemplate $ pfx "" + , bindir = toFlag $ toPathTemplate $ pfx "binaries" + } + , savedConfigureFlags = + mempty { configPackageDB = + toFlag $ SpecificPackageDB $ pfx "package.db" + } + } + + pfx = ("/path with spaces" ) + + +assertProgramOutput :: (String -> Bool) -> FilePath -> [String] + -> HUnit.Assertion +assertProgramOutput f = assertProgram "has proper output" $ + \(c, s, _) -> (c == ExitSuccess) && f s + +assertExitsSuccess :: FilePath -> [String] -> HUnit.Assertion +assertExitsSuccess = assertProgram "exits successfully" $ + (ExitSuccess ==) . fst3 + +assertExitsFailure :: FilePath -> [String] -> HUnit.Assertion +assertExitsFailure = assertProgram "exits with failure" $ + (ExitSuccess /=) . fst3 + +fst3 :: (a, b, c) -> a +fst3 (x, _, _) = x + +assertProgram :: String -> ((ExitCode, String, String) -> Bool) -> FilePath -> [String] + -> HUnit.Assertion +assertProgram desc f progPath progArgs = do + res <- readProcessWithExitCode progPath progArgs "" + let msg = concat [ desc + , " failed for " + , progPath + , " " + , show progArgs + , ": " + , show res + ] + HUnit.assertBool msg $ f res + +-- |Check that cabal-dev add-source makes a package installable by +-- cabal-dev and that cabal-dev install for that package afterwards +-- makes it available in the sandbox, but not outside. +addSourceStaysSandboxed :: Verbosity -> FilePath -> FilePath + -> HUnit.Assertion +addSourceStaysSandboxed v cabalDev dirName = + withTempPackage v dirName $ \readPackageIndex packageDir sb pId -> do + let pkgStr = display pId + sbPkgs <- readPackageIndex (privateStack sb) + gPkgs <- readPackageIndex globalStack + + -- XXX: Cabal returns a single "empty" package if you try to + -- read an empty package db, so we remove any package that has + -- an empty name before comparing + let s = filter ((/= "") . display) . + map installedPackageId . + allPackages + + HUnit.assertEqual + "Newly created package index should be empty" + (s gPkgs) (s sbPkgs) + + let withCabalDev f aa = do + f cabalDev (["-s", sandbox sb] ++ aa) + + -- Fails because the package is not available. XXX: this + -- could fail if our randomly chosen filename is available on + -- hackage. We should actually use a cabal-install config + -- with an empty package index + withCabalDev assertExitsFailure ["install", pkgStr] + + withCabalDev assertExitsSuccess ["add-source", packageDir] + + -- Do the installation. Now this library should be registered + -- with GHC + withCabalDev assertExitsSuccess + ["install", pkgStr, "--verbose=" ++ showForCabal v] + + -- Check that we can find the library in our private package db stack + pkgIdx' <- readPackageIndex (privateStack sb) + info v $ dumpIndex pkgIdx' + case lookupSourcePackageId pkgIdx' pId of + [] -> HUnit.assertFailure $ + "After installation, package " ++ pkgStr ++ " was not found" + [_] -> return () + _ -> HUnit.assertFailure $ + "Unexpectedly got more than one match for " ++ pkgStr + + -- And that we can't find it in the shared package db stack + sharedIdx <- readPackageIndex sharedStack + info v $ dumpIndex sharedIdx + case lookupSourcePackageId sharedIdx pId of + [] -> return () + _ -> HUnit.assertFailure $ + "Found " ++ pkgStr ++ " in a shared package db!" + where + -- The package dbs that cabal-dev will consult + privateStack sb = [GlobalPackageDB, SpecificPackageDB $ pkgConf sb] + + globalStack = [GlobalPackageDB] + +-- |Test that the existence or non-existence of the logs directory +-- does not cause build failures. +-- +-- Before this test, we had a bug that derived from +-- System.Directory.canonicalizePath behaving differently depending on +-- the state of the filesystem. This test tickled the bug, and now we +-- are not using canonicalizePath. +assertLogLocationOk :: Verbosity -> FilePath -> HUnit.Assertion +assertLogLocationOk v cabalDev = + mapM_ setupLogs + [ -- Works fine when its not there + (assertExitsSuccess, const $ return ()) + + , -- Works fine when its a directory + (assertExitsSuccess, createDirectory) + + , -- Fails if it's a file + (assertExitsFailure, (`writeFile` "bogus log data")) + ] + where + setupLogs (expectation, act) = + withTempPackage v "check-build-log." $ \_ packageDir sb pId -> do + let pkgStr = display pId + let logsPth = sandbox sb "logs" + let lsMsg msg = + when (v >= verbose) $ do + putStrLn msg + _ <- rawSystem "ls" ["-ld", logsPth] + return () + let withCabalDev f aa = do + f cabalDev (["-s", sandbox sb] ++ aa) + + _ <- act logsPth + lsMsg "BEFORE" + _ <- withCabalDev assertExitsSuccess ["add-source", packageDir] + _ <- withCabalDev expectation ["install", pkgStr] + lsMsg "AFTER" + +assertTarFileOk :: Verbosity -> FilePath -> HUnit.Assertion +assertTarFileOk v cabalDev = + withTempPackage v "check-tar-file." $ \_ packageDir sb pId -> do + let withCabalDev f aa = do + f cabalDev (["-s", sandbox sb] ++ aa) + _ <- withCabalDev assertExitsSuccess ["add-source", packageDir] + withBinaryFile (indexTar sb) ReadMode $ \h -> do + entries <- Tar.read `fmap` L.hGetContents h + let selectCabalFile _ m@(Just _) = m + selectCabalFile e Nothing = do + case Tar.entryContent e of + Tar.NormalFile b _ | isCabalFile e -> Just b + _ -> Nothing + isCabalFile e = takeExtension (Tar.entryPath e) == ".cabal" + let c = Tar.foldEntries selectCabalFile Nothing (const Nothing) entries + case c of + Nothing -> HUnit.assertFailure "Failed to find a cabal file" + Just extracted -> + let baseCabalName = display (packageName pId) <.> "cabal" + in withBinaryFile (packageDir baseCabalName) ReadMode $ \h1 -> + do original <- L.hGetContents h1 + HUnit.assertEqual "Cabal files before and after tarring" + original extracted + print (L.length original, L.length extracted) + L.putStr original + +---------------------------------------------------------------- +-- Utility code for testing sandboxing + +-- Check that this string contains a numeric version +checkNumericVersion :: String -> Bool +checkNumericVersion s = + case lines s of + [l] -> case simpleParse l of + Just v -> let _ = v :: Version + in True + Nothing -> False + _ -> False + +-- |Generate a minimal cabal file for a given package identifier +-- +-- This Cabal file is useful for testing whether cabal-install can +-- install things, and what the side-effects of installing a package +-- are. Note that there are many side-effects that are not invoked by +-- this package, however! +genCabalFile :: PackageIdentifier -> String +genCabalFile pId = + unlines + [ "Name: " ++ display (pkgName pId) + , "Version: " ++ display (pkgVersion pId) + , "Build-type: Simple" + , "Cabal-version: >=1.2" + , "Maintainer: nobody" + , "Description: This package contains no source code, and only enough in\ + \ the Cabal file to make it buildable" + , "Category: Testing" + , "License: BSD3" + , "Synopsis: The most minimal package that will build" + , "Library" + , " build-depends: base" + ] + +-- |Generate a random Cabal package identifier +-- +-- XXX: If the package identifier is over a certain size, then +-- cabal-install will fail because a filename is "too long." It's +-- unclear what this limit is, but this function has been tweaked to +-- generate a shorter name. There is still a big enough range of +-- values that it should be pretty easy to find a name that doesn't +-- conflict with something else, though. +mkRandomPkgId :: RandomGen g => Rand g PackageIdentifier +mkRandomPkgId = PackageIdentifier <$> getRandomName <*> getRandomVersion + where + getRandomVersion = Version <$> getRandomBranch <*> pure tags + where tags = [] + + -- A branch is a version number + getRandomBranch = do + n <- getRandomR (1, 4) + replicateM n $ getRandomR (0, 100) + + getRandomName = do + i <- getRandomR (1, 5) + segs <- replicateM i getRandomSegment + return $ PackageName $ intercalate "-" segs + + -- A Cabal package name segment must be at least one character + -- long, consist of alphanumeric characters, and contain at + -- least one letter. + getRandomSegment = do + aChar <- getRandomChar pkgLetter + before <- getRandomStr pkgChar 5 + after <- getRandomStr pkgChar 5 + return $ before ++ [aChar] ++ after + + -- Given a predicate, select a random character from the first + -- 256 characters that satsifies that predicate. An exception + -- will be raised if no character matches the predicate. + getRandomChar p = do + let rng = filter p ['\0'..'\255'] + i <- getRandomR (0, length rng - 1) + return $ rng !! i + + -- Get a random string of characters that match the predicate p + -- of length [0..n] + getRandomStr p n = do + i <- getRandomR (0, n) + replicateM i $ getRandomChar p + + pkgLetter c = isAscii c && isLetter c + + pkgChar c = isAscii c && isAlphaNum c + +-- A human-readable package index dump +dumpIndex :: PackageIndex -> String +dumpIndex pkgIdx = unlines $ "Package index contents:": + map (showString " " . display . packageId) + (allPackages pkgIdx) + +-- Return a program database containing the programs we need to +-- load a package index +configurePrerequisites :: Verbosity -> IO ProgramConfiguration +configurePrerequisites v = + configureAllKnownPrograms v $ + addKnownPrograms toConfigure emptyProgramConfiguration + where + -- The programs that need to be configured in order to load a + -- package index + toConfigure = [ ghcPkgProgram + , ghcProgram + ] + +-- A package db stack that includes only shared package databases +sharedStack :: [PackageDB] +sharedStack = [GlobalPackageDB, UserPackageDB] + +-- Given a package index, generate a package name that is not in +-- that index. It is unlikely that a randomly generated name +-- will be in the package index, but we will try three times to +-- make it wildly unlikely. +findUnusedPackageId :: Verbosity -> PackageIndex -> IO PackageIdentifier +findUnusedPackageId v pkgIdx = go [] + where + go ps = do + when (length ps > 2) $ HUnit.assertFailure $ + showString "Failed to find an unused package id. Tried:" $ + intercalate " " $ + map display ps + + pId <- evalRandIO mkRandomPkgId + case searchByName pkgIdx (display $ packageName pId) of + None -> do info v $ "Found unused package " ++ display pId + return pId + _ -> go (pId:ps) + +-- |Create a dummy Cabal package in a temporary directory and invoke a +-- function with the state dependent on the temporary directory. +withTempPackage + :: Verbosity -> String + -> (([PackageDB] -> IO PackageIndex) + -> FilePath + -> Sandbox KnownVersion -> PackageIdentifier -> IO a) + -> IO a +withTempPackage v dirName f = + do pConf <- configurePrerequisites v + let readPackageIndex stack = getInstalledPackages v stack pConf + + -- Get the shared package index and choose a package identifier + -- that is not in it + pkgIdx <- readPackageIndex sharedStack + info v $ dumpIndex pkgIdx + pId <- findUnusedPackageId v pkgIdx + + -- Create a temporary directory in which to build and install + -- the bogus package + tmp <- getTemporaryDirectory + withTempDirectory v tmp dirName $ \d -> do + let sandboxDir = d "cabal-dev" + let packageDir = d "pkg" + let cabalFileName = packageDir display (pkgName pId) <.> "cabal" + createDirectory packageDir + writeFile cabalFileName (genCabalFile pId) + info v $ unlines [ "Generated cabal file:" + , genCabalFile pId + ] + when (v >= verbose) $ rawSystem "ls" ["-l"] >> return () + + sb <- initPkgDb v =<< newSandbox v sandboxDir + f readPackageIndex packageDir sb pId