diff --git a/cabal-dev.cabal b/cabal-dev.cabal --- a/cabal-dev.cabal +++ b/cabal-dev.cabal @@ -1,5 +1,5 @@ Name: cabal-dev -Version: 0.7.3.2 +Version: 0.7.4.0 Synopsis: Manage sandboxed Haskell build environments Description: cabal-dev is a tool for managing development builds of diff --git a/src/Distribution/Dev/AddSource.hs b/src/Distribution/Dev/AddSource.hs --- a/src/Distribution/Dev/AddSource.hs +++ b/src/Distribution/Dev/AddSource.hs @@ -68,7 +68,6 @@ 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 @@ -92,39 +91,33 @@ 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 + 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 + -- 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 @@ -196,9 +189,8 @@ -> 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 = +installTarball flgs sandbox src pkgId pkgDesc = do createDirectoryIfMissing True $ localRepoPath sandbox repoDir pkgId case src of TarPkg fn -> do copyFile fn dest @@ -228,7 +220,7 @@ -- program. We do this to work -- around a different bug in Cabal -- (http://hackage.haskell.org/trac/hackage/ticket/731) - rawSystem "cabal" ["configure"] + _ <- rawSystem "cabal" ["configure"] rawSystem "dist/setup/setup" ["sdist"] _ -> rawSystem "cabal" ["sdist"] diff --git a/src/Distribution/Dev/InstallDependencies.hs b/src/Distribution/Dev/InstallDependencies.hs --- a/src/Distribution/Dev/InstallDependencies.hs +++ b/src/Distribution/Dev/InstallDependencies.hs @@ -27,12 +27,11 @@ installDependencies flgs pkgNames = do let v = getVerbosity flgs s <- initPkgDb v =<< resolveSandbox flgs - setupRes <- setup s flgs + (cabal, _) <- requireProgram v cabalProgram emptyProgramDb + setupRes <- setup s cabal flgs case setupRes of Left err -> return $ CommandError err - Right args -> - do - (cabal, _) <- requireProgram v cabalProgram emptyProgramDb + Right args -> do out <- getProgramOutput v cabal $ concat [ args , ["install", "--dry-run", "--verbose=1"] diff --git a/src/Distribution/Dev/InvokeCabal.hs b/src/Distribution/Dev/InvokeCabal.hs --- a/src/Distribution/Dev/InvokeCabal.hs +++ b/src/Distribution/Dev/InvokeCabal.hs @@ -8,11 +8,12 @@ ) where -import Distribution.Version ( Version(..) ) +import Distribution.Version ( Version(..), VersionRange, withinRange, earlierVersion ) import Distribution.Verbosity ( Verbosity, showForCabal ) import Distribution.Simple.Program ( Program( programFindVersion , programFindLocation ) + , ConfiguredProgram , emptyProgramConfiguration , findProgramVersion , locationPath @@ -20,11 +21,12 @@ , programVersion , requireProgram , runProgram + , getProgramOutput , simpleProgram ) import Distribution.Simple.Utils ( withUTF8FileContents, writeUTF8File , debug, cabalVersion ) -import Distribution.Text ( display ) +import Distribution.Text ( display, simpleParse ) import System.Console.GetOpt ( OptDescr ) import Distribution.Dev.Command ( CommandActions(..) @@ -60,34 +62,41 @@ invokeCabal flgs args = do let v = getVerbosity flgs s <- initPkgDb v =<< resolveSandbox flgs - res <- setup s flgs + cabal <- findCabalOnPath v + res <- setup s cabal flgs case res of Left err -> return $ CommandError err Right args' -> do - invokeCabalCfg v $ args' ++ args + runProgram v cabal $ args' ++ args return CommandOk -cabalArgs :: Config -> IO (Either String [String]) -cabalArgs flgs = do +cabalArgs :: ConfiguredProgram -> Config -> IO (Either String [String]) +cabalArgs cabal flgs = do let v = getVerbosity flgs s <- initPkgDb v =<< resolveSandbox flgs - setup s flgs + setup s cabal flgs -setup :: Sandbox KnownVersion-> Config -> IO (Either String [String]) -setup s flgs = do +setup :: Sandbox KnownVersion -> ConfiguredProgram -> Config -> IO (Either String [String]) +setup s cabal flgs = do let v = getVerbosity flgs + verOut <- getProgramOutput v cabal ["--version"] 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 + case cabalVer verOut of + Left err -> return $ Left err + Right ver -> do + cabalHome <- getAppUserDataDirectory "cabal" + let qInstDirs = withinRange ver cabalNeedsQuotes + rew = R.Rewrite cabalHome (sandbox s) (pkgConf s) qInstDirs + withUTF8FileContents cfgIn $ \cIn -> + do cfgRes <- R.rewriteCabalConfig rew 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 = @@ -135,12 +144,26 @@ findProgramVersion "--numeric-version" id } -invokeCabalCfg :: Verbosity -> [String] -> IO () -invokeCabalCfg v args = do +findCabalOnPath :: Verbosity -> IO ConfiguredProgram +findCabalOnPath v = 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 + return cabal + +cabalVer :: String -> Either String Version +cabalVer str = + case lines str of + [] -> Left "No version string provided." + [_] -> Left "Could not find Cabal version line." + (_:ln:_) -> case simpleParse ((words ln)!!2) of + Just v -> Right v + Nothing -> Left $ err ln + where err line = "Could not parse Cabal verison.\n" + ++ "(simpleParse "++show line++")" + +cabalNeedsQuotes :: VersionRange +cabalNeedsQuotes = earlierVersion $ Version [1,10] [] diff --git a/src/Distribution/Dev/RewriteCabalConfig.hs b/src/Distribution/Dev/RewriteCabalConfig.hs --- a/src/Distribution/Dev/RewriteCabalConfig.hs +++ b/src/Distribution/Dev/RewriteCabalConfig.hs @@ -20,17 +20,18 @@ import Distribution.ParseUtils ( readFields, ParseResult(..), Field(..) ) import Text.PrettyPrint.HughesPJ -data Rewrite = Rewrite { homeDir :: FilePath - , sandboxDir :: FilePath - , packageDb :: FilePath +data Rewrite = Rewrite { homeDir :: FilePath + , sandboxDir :: FilePath + , packageDb :: FilePath + , quoteInstallDirs :: Bool } -- |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) +rewriteCabalConfig r = rewriteConfig expand (setPackageDb $ packageDb r) + where + expand = expandCabalConfig (quoteInstallDirs r) (homeDir r) (sandboxDir r) -- |Given an expansion configuration, read the input config file and -- write the expansion into the output config file @@ -113,8 +114,13 @@ -- -- 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 = +expandCabalConfig :: Bool -- ^Whether the install-dirs section of the + -- cabal config file will quote paths. + -- Versions of cabal-install prior to 0.9 + -- required quoting. Versions 0.9 and later + -- forbit it. + -> FilePath -> FilePath -> Expand IO +expandCabalConfig shouldQuote home sandbox = Expand { eExpand = ePath , eLeaves = [ "remote-repo-cache" , "local-repo" @@ -134,7 +140,7 @@ } where expandInstallDirs = - Expand { eExpand = fmap show . ePath + Expand { eExpand = quote . ePath , eLeaves = [ "prefix" , "bindir" @@ -149,5 +155,9 @@ ] , eSections = [] } + + -- How install-dirs should quote its paths + quote | shouldQuote = fmap show + | otherwise = id ePath = return . expandDot sandbox . expandTilde home diff --git a/test/RunTests.hs b/test/RunTests.hs --- a/test/RunTests.hs +++ b/test/RunTests.hs @@ -27,6 +27,7 @@ import Distribution.Text ( simpleParse, display ) import Distribution.Verbosity ( normal, Verbosity, showForCabal, verbose ) import Distribution.Version ( Version(..) ) +import Distribution.Dev.Flags ( parseGlobalFlags ) import Distribution.Dev.InitPkgDb ( initPkgDb ) import Distribution.Dev.Sandbox ( newSandbox, pkgConf, Sandbox, KnownVersion, sandbox, indexTar ) import System.IO ( withBinaryFile, IOMode(ReadMode) ) @@ -39,6 +40,7 @@ import System.Random ( RandomGen ) import Test.Framework ( defaultMainWithArgs, Test, testGroup ) import Test.Framework.Providers.HUnit ( testCase ) +import Test.HUnit ( (@?=) ) import qualified Test.HUnit as HUnit import Distribution.Client.Config -- ( parseConfig ) @@ -84,6 +86,9 @@ , testCase "exits with failure when no arguments are supplied" $ assertExitsFailure p [] + + , testCase "short flag is passed through to cabal" $ + assertShortFlags ] main :: IO () @@ -161,6 +166,13 @@ assertExitsFailure :: FilePath -> [String] -> HUnit.Assertion assertExitsFailure = assertProgram "exits with failure" $ (ExitSuccess /=) . fst3 + + +-- | Test for short flags. Verifies that a short flag can make it past the cabal-dev +-- command line arg parser (and then, presumably, to cabal-install). +-- Created due to issue 6: https://github.com/creswick/cabal-dev/issues#issue/6 +assertShortFlags :: HUnit.Assertion +assertShortFlags = (parseGlobalFlags $ words "install -f-curl") @?= ([],["install", "-f-curl"],[]) fst3 :: (a, b, c) -> a fst3 (x, _, _) = x