cabal-dev (empty) → 0.7
raw patch · 16 files changed
+2060/−0 lines, 16 filesdep +Cabaldep +HTTPdep +HUnitbuild-type:Customsetup-changedbinary-added
Dependencies added: Cabal, HTTP, HUnit, MonadRandom, Win32, array, base, bytestring, containers, directory, filepath, mtl, network, pretty, process, random, tar, test-framework, test-framework-hunit, zlib
Files
- LICENSE +30/−0
- Setup.hs +41/−0
- admin/00-index.tar binary
- admin/cabal-config.in +84/−0
- cabal-dev.cabal +135/−0
- src/Distribution/Dev/AddSource.hs +402/−0
- src/Distribution/Dev/Command.hs +20/−0
- src/Distribution/Dev/Flags.hs +129/−0
- src/Distribution/Dev/InitPkgDb.hs +72/−0
- src/Distribution/Dev/InstallDependencies.hs +58/−0
- src/Distribution/Dev/InvokeCabal.hs +143/−0
- src/Distribution/Dev/RewriteCabalConfig.hs +153/−0
- src/Distribution/Dev/Sandbox.hs +117/−0
- src/GhcPkgCompat.hs +67/−0
- src/Main.hs +140/−0
- test/RunTests.hs +469/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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 }
+ admin/00-index.tar view
binary file changed (absent → 10240 bytes)
+ admin/cabal-config.in view
@@ -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
+ cabal-dev.cabal view
@@ -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
+ src/Distribution/Dev/AddSource.hs view
@@ -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)
+ src/Distribution/Dev/Command.hs view
@@ -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+ }
+ src/Distribution/Dev/Flags.hs view
@@ -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
+ src/Distribution/Dev/InitPkgDb.hs view
@@ -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)
+ src/Distribution/Dev/InstallDependencies.hs view
@@ -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
+ src/Distribution/Dev/InvokeCabal.hs view
@@ -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
+ src/Distribution/Dev/RewriteCabalConfig.hs view
@@ -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
+ src/Distribution/Dev/Sandbox.hs view
@@ -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
+ src/GhcPkgCompat.hs view
@@ -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
+ src/Main.hs view
@@ -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 ++ " <command>"+ , ""+ , "Where <command> 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
+ test/RunTests.hs view
@@ -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