diff --git a/cabal-install/Distribution/Client/Exec.hs b/cabal-install/Distribution/Client/Exec.hs index 2d59681fba4..4a7097e188c 100644 --- a/cabal-install/Distribution/Client/Exec.hs +++ b/cabal-install/Distribution/Client/Exec.hs @@ -19,9 +19,8 @@ import Data.Foldable (forM_) import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import Distribution.Client.Sandbox (getSandboxConfigFilePath) import Distribution.Client.Sandbox.PackageEnvironment (sandboxPackageDBPath) -import Distribution.Client.Sandbox.Types (UseSandbox (..)) +import Distribution.Client.Sandbox.Types (UseSandbox (..), SandboxMetadata(..)) import Distribution.Simple.Compiler (Compiler, CompilerFlavor(..), compilerFlavor) import Distribution.Simple.Program (ghcProgram, ghcjsProgram, lookupProgram) @@ -38,7 +37,6 @@ import System.Directory ( doesDirectoryExist ) import System.FilePath (searchPathSeparator, ()) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) -import Data.Monoid (mempty) #endif @@ -65,23 +63,23 @@ exec verbosity useSandbox comp platform programDb extraArgs = [] -> die "Please specify an executable to run" where - environmentOverrides = + environmentOverrides = case useSandbox of NoSandbox -> return [] - (UseSandbox sandboxDir) -> - sandboxEnvironment verbosity sandboxDir comp platform programDb + (UseSandbox sandboxMetadata) -> + sandboxEnvironment verbosity sandboxMetadata comp platform programDb -- | Return the package's sandbox environment. -- -- The environment sets GHC_PACKAGE_PATH so that GHC will use the sandbox. sandboxEnvironment :: Verbosity - -> FilePath + -> SandboxMetadata -> Compiler -> Platform -> ProgramDb -> IO [(String, Maybe String)] -sandboxEnvironment verbosity sandboxDir comp platform programDb = +sandboxEnvironment verbosity sandboxMetadata comp platform programDb = case compilerFlavor comp of GHC -> env GHC.getGlobalPackageDB ghcProgram "GHC_PACKAGE_PATH" GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH" @@ -90,7 +88,7 @@ sandboxEnvironment verbosity sandboxDir comp platform programDb = env getGlobalPackageDB hcProgram packagePathEnvVar = do let Just program = lookupProgram hcProgram programDb gDb <- getGlobalPackageDB verbosity program - sandboxConfigFilePath <- getSandboxConfigFilePath mempty + let sandboxConfigFilePath = smSandboxConfigFile sandboxMetadata let compilerPackagePath = hcPackagePath gDb -- Packages database must exist, otherwise things will start -- failing in mysterious ways. @@ -104,6 +102,7 @@ sandboxEnvironment verbosity sandboxDir comp platform programDb = ] hcPackagePath gDb = + let sandboxDir = smSandboxDirectory sandboxMetadata in let s = sandboxPackageDBPath sandboxDir comp platform in Just $ prependToSearchPath gDb s @@ -129,5 +128,6 @@ requireProgram' verbosity useSandbox programDb exe = do flip modifyProgramSearchPath programDb $ \searchPath -> case useSandbox of NoSandbox -> searchPath - UseSandbox sandboxDir -> + UseSandbox sandboxMetadata -> + let sandboxDir = smSandboxDirectory sandboxMetadata in ProgramSearchPathDir (sandboxDir "bin") : searchPath diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 908b81d1c59..6937ef50303 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -89,7 +89,7 @@ import Distribution.Client.Sandbox.Timestamp ( withUpdateTimestamps ) import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..), UseSandbox(..), isUseSandbox - , whenUsingSandbox ) + , whenUsingSandbox, SandboxMetadata(..) ) import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Types as Source import Distribution.Client.BuildReports.Types @@ -997,7 +997,7 @@ updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo -> Compiler -> Platform -> InstallPlan -> IO () -updateSandboxTimestampsFile (UseSandbox sandboxDir) +updateSandboxTimestampsFile (UseSandbox sandboxMetadata) (Just (SandboxPackageInfo _ _ _ allAddSourceDeps)) comp platform installPlan = withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do @@ -1009,6 +1009,8 @@ updateSandboxTimestampsFile (UseSandbox sandboxDir) <- map packageSource allSrcPkgs] allPathsCanonical <- mapM tryCanonicalizePath allPaths return $! filter (`S.member` allAddSourceDeps) allPathsCanonical + where + sandboxDir = smSandboxDirectory sandboxMetadata updateSandboxTimestampsFile _ _ _ _ _ = return () diff --git a/cabal-install/Distribution/Client/Sandbox.hs b/cabal-install/Distribution/Client/Sandbox.hs index 0e975294a23..512588638c3 100644 --- a/cabal-install/Distribution/Client/Sandbox.hs +++ b/cabal-install/Distribution/Client/Sandbox.hs @@ -19,7 +19,7 @@ module Distribution.Client.Sandbox ( dumpPackageEnvironment, withSandboxBinDirOnSearchPath, - getSandboxConfigFilePath, + getSandboxMetadata, loadConfigOrSandboxConfig, findSavedDistPref, initPackageDBIfNeeded, @@ -35,7 +35,6 @@ module Distribution.Client.Sandbox ( tryGetIndexFilePath, sandboxBuildDir, getInstalledPackagesInSandbox, - updateSandboxConfigFileFlag, updateInstallDirs, -- FIXME: move somewhere else @@ -62,18 +61,20 @@ import Distribution.Utils.NubList ( fromNubList ) import Distribution.Client.Sandbox.PackageEnvironment ( PackageEnvironment(..), PackageEnvironmentType(..) - , createPackageEnvironmentFile, classifyPackageEnvironment + , createPackageEnvironmentFile , tryLoadSandboxPackageEnvironmentFile, loadUserConfig , commentPackageEnvironment, showPackageEnvironmentWithComments , sandboxPackageEnvironmentFile, userPackageEnvironmentFile ) import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..) + , SandboxMetadata(..) , UseSandbox(..) ) import Distribution.Client.SetupWrapper ( SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Types ( PackageLocation(..) , SourcePackage(..) ) import Distribution.Client.Utils ( inDir, tryCanonicalizePath - , tryFindAddSourcePackageDesc ) + , tryFindAddSourcePackageDesc + , parentsOfCurrentDirectory ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.PackageDescription.Parse ( readPackageDescription ) @@ -86,7 +87,8 @@ import Distribution.Simple.Configure ( configCompilerAuxEx import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Program ( ProgramConfiguration ) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) - , fromFlagOrDefault ) + , fromFlagOrDefault + , flagToMaybe) import Distribution.Simple.SrcDist ( prepareTree ) import Distribution.Simple.Utils ( die, debug, notice, info, warn , debugNoWrap, defaultPackageDesc @@ -111,7 +113,7 @@ import Data.Char ( ord ) import Data.Foldable ( forM_ ) import Data.IORef ( newIORef, writeIORef, readIORef ) import Data.List ( delete, foldl' ) -import Data.Maybe ( fromJust ) +import Data.Maybe ( fromJust, isJust ) #if !MIN_VERSION_base(4,8,0) import Data.Monoid ( mempty, mappend ) #endif @@ -169,41 +171,41 @@ sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash "" -- * Basic sandbox functions. -- --- | If @--sandbox-config-file@ wasn't given on the command-line, set it to the --- value of the @CABAL_SANDBOX_CONFIG@ environment variable, or else to --- 'NoFlag'. -updateSandboxConfigFileFlag :: GlobalFlags -> IO GlobalFlags -updateSandboxConfigFileFlag globalFlags = - case globalSandboxConfigFile globalFlags of - Flag _ -> return globalFlags - NoFlag -> do - fp <- lookupEnv "CABAL_SANDBOX_CONFIG" - forM_ fp $ \fp' -> do -- Check for existence if environment variable set - exists <- doesFileExist fp' - unless exists $ die $ "Cabal sandbox file in $CABAL_SANDBOX_CONFIG does not exist: " ++ fp' - let f' = maybe NoFlag Flag fp - return globalFlags { globalSandboxConfigFile = f' } - --- | Return the path to the sandbox config file - either the default or the one --- specified with @--sandbox-config-file@. -getSandboxConfigFilePath :: GlobalFlags -> IO FilePath -getSandboxConfigFilePath globalFlags = do - let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags - case sandboxConfigFileFlag of - NoFlag -> do pkgEnvDir <- getCurrentDirectory - return (pkgEnvDir sandboxPackageEnvironmentFile) - Flag path -> return path - --- | Load the @cabal.sandbox.config@ file (and possibly the optional --- @cabal.config@). In addition to a @PackageEnvironment@, also return a --- canonical path to the sandbox. Exit with error if the sandbox directory or --- the package environment file do not exist. -tryLoadSandboxConfig :: Verbosity -> GlobalFlags - -> IO (FilePath, PackageEnvironment) -tryLoadSandboxConfig verbosity globalFlags = do - path <- getSandboxConfigFilePath globalFlags - tryLoadSandboxPackageEnvironmentFile verbosity path - (globalConfigFile globalFlags) +-- | Get sandbox metadata, given current environment variables global +-- configuration, etc. Exit with error if the sandbox configuration, +-- directory or the package environment file do not exist. +getSandboxMetadata :: Verbosity -> GlobalFlags -> IO SandboxMetadata +getSandboxMetadata verbosity globalFlags = do + -- FIXME: Could probably be prettified drastically by exploiting the Monad instance for Maybe... + maybeConfigFilePath <- case globalSandboxConfigFile globalFlags of + Flag fp -> return $ Just fp -- Command line flag wins over environment variable + NoFlag -> lookupEnv "CABAL_SANDBOX_CONFIG" + -- Check for the existence of the cabal sandbox configuration file; regardless of + -- how it was specified. If it was explicitly specified explicitly then it *must* exist. + forM_ maybeConfigFilePath $ \fp -> do + exists <- doesFileExist fp + unless exists $ die $ "Cabal sandbox file does not exist: " ++ fp + -- If we don't have a config file, then we search for one to see if we can + -- find an enclosing sandbox somewhere. + maybeConfigFilePath' <- case maybeConfigFilePath of + Nothing -> do pkgEnvDir <- searchForSandbox -- FIXME: Search should perhaps be in loadConfigOrSandboxConfig? + -- FIXME: Not sure; could we just do current dir if we don't find a sandbox? Or should we "error"? + -- ... or maybe we need to rework the whole thing to avoid having to "look into" GlobalFlags all the time... + return $ fmap (\x -> x sandboxPackageEnvironmentFile {- FIXME: flip? --} ) pkgEnvDir + Just fp -> return $ Just fp -- FIXME: ugh... + -- Do we have a config file or not? + case maybeConfigFilePath' of + Nothing -> + error $ "No sandbox found?!?" -- FIXME: Message should be available from old code + Just configFilePath' -> do + -- Extract the package environment and sandbox directory, + (sandboxDir, pkgEnv) <- tryLoadSandboxPackageEnvironmentFile verbosity configFilePath' (globalConfigFile globalFlags) + -- Build up the metadata descriptor + return SandboxMetadata { + smSandboxConfigFile = configFilePath', + smSandboxDirectory = sandboxDir, + smPackageEnvironment = pkgEnv + } -- | Return the name of the package index file for this package environment. tryGetIndexFilePath :: SavedConfig -> IO FilePath @@ -287,14 +289,24 @@ initPackageDBIfNeeded verbosity configFlags comp conf = do debug verbosity $ "The package database already exists: " ++ dbPath -- | Entry point for the 'cabal sandbox dump-pkgenv' command. -dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () -dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do - (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - commentPkgEnv <- commentPackageEnvironment sandboxDir - putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv +dumpPackageEnvironment :: SandboxMetadata -> IO () +dumpPackageEnvironment sandboxMetadata = do + commentPkgEnv <- commentPackageEnvironment $ smSandboxDirectory sandboxMetadata + putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ smPackageEnvironment sandboxMetadata + +-- | Create the sandbox configuration file path. This function +-- is __not__ meant for use outside this module! +getSandboxConfigFilePath :: GlobalFlags -> IO FilePath +getSandboxConfigFilePath globalFlags = do + let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags + -- FIXME: is there any meaningful code reuse between this and the functionality getSandboxMetadata? + case sandboxConfigFileFlag of + NoFlag -> do pkgEnvDir <- getCurrentDirectory + return (pkgEnvDir sandboxPackageEnvironmentFile) + Flag path -> return path -- | Entry point for the 'cabal sandbox init' command. -sandboxInit :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () +sandboxInit :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () sandboxInit verbosity sandboxFlags globalFlags = do -- Warn if there's a 'cabal-dev' sandbox. isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev") @@ -318,8 +330,7 @@ sandboxInit verbosity sandboxFlags globalFlags = do -- Create the package environment file. pkgEnvFile <- getSandboxConfigFilePath globalFlags - createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile comp platform - (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags + pkgEnv <- createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile comp platform let config = pkgEnvSavedConfig pkgEnv configFlags = savedConfigureFlags config @@ -344,7 +355,7 @@ sandboxDelete verbosity _sandboxFlags globalFlags = do globalFlags { globalRequireSandbox = Flag False } case useSandbox of NoSandbox -> warn verbosity "Not in a sandbox." - UseSandbox sandboxDir -> do + UseSandbox sandboxMetadata -> do curDir <- getCurrentDirectory pkgEnvFile <- getSandboxConfigFilePath globalFlags @@ -358,6 +369,9 @@ sandboxDelete verbosity _sandboxFlags globalFlags = do ++ pkgEnvFile ++ "'.\n Please delete manually." else removeFile pkgEnvFile + -- Get the sandbox directory + let sandboxDir = smSandboxDirectory sandboxMetadata + -- Remove the sandbox directory, unless we're using a shared sandbox. let isNonDefaultSandboxLocation = not $ equalFilePath sandboxDir $ curDir defaultSandboxLocation @@ -392,11 +406,10 @@ doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do return buildTreeRefs' -- | Entry point for the 'cabal sandbox add-source' command. -sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags - -> IO () -sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do - (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - +sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> SandboxMetadata -> IO () +sandboxAddSource verbosity buildTreeRefs sandboxFlags sandboxMetadata = do + let sandboxDir = smSandboxDirectory sandboxMetadata + let pkgEnv = smPackageEnvironment sandboxMetadata if fromFlagOrDefault False (sandboxSnapshot sandboxFlags) then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef @@ -447,13 +460,12 @@ sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef -- | Entry point for the 'cabal sandbox delete-source' command. -sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags - -> IO () -sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do - (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) +sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxMetadata -> IO () +sandboxDeleteSource verbosity buildTreeRefs sandboxMetadata = do + let pkgEnv = smPackageEnvironment sandboxMetadata + indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) - withRemoveTimestamps sandboxDir $ do + withRemoveTimestamps (smSandboxDirectory sandboxMetadata) $ do Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++ @@ -461,12 +473,11 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do "from the sandbox package DB.\n\n" ++ "Use 'sandbox hc-pkg -- unregister' to do that." +-- FIXME: Can we remove globalFlags from more of the functions in here?!? -- | Entry point for the 'cabal sandbox list-sources' command. -sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags - -> IO () -sandboxListSources verbosity _sandboxFlags globalFlags = do - (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) +sandboxListSources :: Verbosity -> SandboxMetadata -> IO () +sandboxListSources verbosity sandboxMetadata = do + indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig $ smPackageEnvironment sandboxMetadata) refs <- Index.listBuildTreeRefs verbosity Index.ListIgnored Index.LinksAndSnapshots indexFile @@ -479,17 +490,20 @@ sandboxListSources verbosity _sandboxFlags globalFlags = do mapM_ putStrLn refs notice verbosity $ "\nTo unregister source dependencies, " ++ "use the 'sandbox delete-source' command." + where + sandboxDir = smSandboxDirectory sandboxMetadata -- | Entry point for the 'cabal sandbox hc-pkg' command. Invokes the @hc-pkg@ -- tool with provided arguments, restricted to the sandbox. -sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO () -sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do - (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags +sandboxHcPkg :: Verbosity -> SandboxMetadata -> [String] -> IO () +sandboxHcPkg verbosity sandboxMetadata extraArgs = do let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv dbStack = configPackageDB' configFlags (comp, _platform, conf) <- configCompilerAux' configFlags Register.invokeHcPkg verbosity comp conf dbStack extraArgs + where + pkgEnv = smPackageEnvironment sandboxMetadata updateInstallDirs :: Flag Bool -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig) @@ -512,6 +526,20 @@ updateInstallDirs userInstallFlag (useSandbox, savedConfig) = userInstall = fromFlagOrDefault defaultUserInstall (configUserInstall configureFlags `mappend` userInstallFlag) +-- | Search for any "enclosing" sandbox, i.e. a sandbox in the current +-- or any parent directory. +searchForSandbox :: IO (Maybe FilePath) +searchForSandbox = do + parentDirectories <- parentsOfCurrentDirectory + go parentDirectories + where + go [] = return Nothing + go (d:t) = do + exists <- doesFileExist (d sandboxPackageEnvironmentFile) + if exists + then return (Just d) + else go t + -- | Check which type of package environment we're in and return a -- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates -- whether we're working in a sandbox. @@ -520,20 +548,28 @@ loadConfigOrSandboxConfig :: Verbosity -- @--sandbox-config-file@. -> IO (UseSandbox, SavedConfig) loadConfigOrSandboxConfig verbosity globalFlags = do - let configFileFlag = globalConfigFile globalFlags + let configFileFlag = globalConfigFile globalFlags sandboxConfigFileFlag = globalSandboxConfigFile globalFlags - ignoreSandboxFlag = globalIgnoreSandbox globalFlags + forceSandboxConfig = isJust . flagToMaybe $ sandboxConfigFileFlag + ignoreSandbox = fromFlagOrDefault False $ globalIgnoreSandbox globalFlags + + pkgEnvDir <- getPkgEnvDir sandboxConfigFileFlag + let configExists fname = doesFileExist (pkgEnvDir fname) + isSandbox <- liftM2 (||) (return forceSandboxConfig) + (configExists sandboxPackageEnvironmentFile) + isUser <- configExists userPackageEnvironmentFile + -- Classify the type of package environment + let pkgEnvType + | isSandbox && not ignoreSandbox = SandboxPackageEnvironment + | isUser = UserPackageEnvironment + | otherwise = AmbientPackageEnvironment - pkgEnvDir <- getPkgEnvDir sandboxConfigFileFlag - pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag - ignoreSandboxFlag case pkgEnvType of -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present. SandboxPackageEnvironment -> do - (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - -- ^ Prints an error message and exits on error. - let config = pkgEnvSavedConfig pkgEnv - return (UseSandbox sandboxDir, config) + sandboxMetadata <- getSandboxMetadata verbosity globalFlags + let config = pkgEnvSavedConfig $ smPackageEnvironment sandboxMetadata + return (UseSandbox sandboxMetadata, config) -- Only @cabal.config@ is present. UserPackageEnvironment -> do @@ -550,12 +586,13 @@ loadConfigOrSandboxConfig verbosity globalFlags = do return (NoSandbox, config) where + -- Return the path to the package environment directory - either the -- current directory or the one that @--sandbox-config-file@ resides in. getPkgEnvDir :: (Flag FilePath) -> IO FilePath getPkgEnvDir sandboxConfigFileFlag = do case sandboxConfigFileFlag of - NoFlag -> getCurrentDirectory + NoFlag -> fmap fromJust searchForSandbox -- FIXME: This one *CAN* quite reasonably fail! Flag path -> tryCanonicalizePath . takeDirectory $ path -- Die if @--require-sandbox@ was specified and we're not inside a sandbox. @@ -582,9 +619,9 @@ findSavedDistPref config flagDistPref = do -- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do -- nothing. maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a -maybeWithSandboxDirOnSearchPath NoSandbox act = act -maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act = - withSandboxBinDirOnSearchPath sandboxDir $ act +maybeWithSandboxDirOnSearchPath NoSandbox act = act +maybeWithSandboxDirOnSearchPath (UseSandbox sandboxMetadata) act = + withSandboxBinDirOnSearchPath (smSandboxDirectory sandboxMetadata) $ act -- | Had reinstallAddSourceDeps actually reinstalled any dependencies? data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled @@ -594,11 +631,12 @@ data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled reinstallAddSourceDeps :: Verbosity -> ConfigFlags -> ConfigExFlags -> InstallFlags -> GlobalFlags - -> FilePath + -> SandboxMetadata -> IO WereDepsReinstalled reinstallAddSourceDeps verbosity configFlags' configExFlags - installFlags globalFlags sandboxDir = topHandler' $ do - let sandboxDistPref = sandboxBuildDir sandboxDir + installFlags globalFlags sandboxMetadata = topHandler' $ do + let sandboxDir = smSandboxDirectory sandboxMetadata + sandboxDistPref = sandboxBuildDir sandboxDir configFlags = configFlags' { configDistPref = Flag sandboxDistPref } haddockFlags = mempty @@ -614,7 +652,7 @@ reinstallAddSourceDeps verbosity configFlags' configExFlags args = ((configPackageDB' configFlags) ,(globalRepos globalFlags) ,comp, platform, conf - ,UseSandbox sandboxDir, Just sandboxPkgInfo + ,UseSandbox sandboxMetadata, Just sandboxPkgInfo ,globalFlags, configFlags, configExFlags, installFlags ,haddockFlags) @@ -709,11 +747,13 @@ maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags maybeWithSandboxPackageInfo verbosity configFlags globalFlags comp platform conf useSandbox cont = case useSandbox of - NoSandbox -> cont Nothing - UseSandbox sandboxDir -> withSandboxPackageInfo verbosity - configFlags globalFlags - comp platform conf sandboxDir - (\spi -> cont (Just spi)) + NoSandbox -> cont Nothing + UseSandbox sandboxMetadata -> do + let sandboxDir = smSandboxDirectory sandboxMetadata + withSandboxPackageInfo verbosity + configFlags globalFlags + comp platform conf sandboxDir + (\spi -> cont (Just spi)) -- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that -- case. diff --git a/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs index 213e07e6933..b8c0df8d36d 100644 --- a/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -11,8 +11,7 @@ module Distribution.Client.Sandbox.PackageEnvironment ( PackageEnvironment(..) - , PackageEnvironmentType(..) - , classifyPackageEnvironment + , PackageEnvironmentType(..) -- FIXME: Why is this in this file? , createPackageEnvironmentFile , tryLoadSandboxPackageEnvironmentFile , readPackageEnvironmentFile @@ -48,7 +47,7 @@ import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate , fromPathTemplate, toPathTemplate ) import Distribution.Simple.Setup ( Flag(..) , ConfigFlags(..), HaddockFlags(..) - , fromFlagOrDefault, toFlag, flagToMaybe ) + , fromFlagOrDefault, toFlag ) import Distribution.Simple.Utils ( die, info, notice, warn ) import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..) , commaListField, commaNewLineListField @@ -58,14 +57,13 @@ import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..) , syntaxError, warning ) import Distribution.System ( Platform ) import Distribution.Verbosity ( Verbosity, normal ) -import Control.Monad ( foldM, liftM2, when, unless ) +import Control.Monad ( foldM, when, unless ) import Data.List ( partition ) -import Data.Maybe ( isJust ) #if !MIN_VERSION_base(4,8,0) import Data.Monoid ( Monoid(..) ) #endif import Distribution.Compat.Exception ( catchIO ) -import System.Directory ( doesDirectoryExist, doesFileExist +import System.Directory ( doesDirectoryExist , renameFile ) import System.FilePath ( (<.>), (), takeDirectory ) import System.IO.Error ( isDoesNotExistError ) @@ -119,26 +117,6 @@ data PackageEnvironmentType = | UserPackageEnvironment -- ^ './cabal.config' | AmbientPackageEnvironment -- ^ '~/.cabal/config' --- | Is there a 'cabal.sandbox.config' or 'cabal.config' in this --- directory? -classifyPackageEnvironment :: FilePath -> Flag FilePath -> Flag Bool - -> IO PackageEnvironmentType -classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag ignoreSandboxFlag = - do isSandbox <- liftM2 (||) (return forceSandboxConfig) - (configExists sandboxPackageEnvironmentFile) - isUser <- configExists userPackageEnvironmentFile - return (classify isSandbox isUser) - where - configExists fname = doesFileExist (pkgEnvDir fname) - ignoreSandbox = fromFlagOrDefault False ignoreSandboxFlag - forceSandboxConfig = isJust . flagToMaybe $ sandboxConfigFileFlag - - classify :: Bool -> Bool -> PackageEnvironmentType - classify True _ - | not ignoreSandbox = SandboxPackageEnvironment - classify _ True = UserPackageEnvironment - classify _ False = AmbientPackageEnvironment - -- | Defaults common to 'initialPackageEnvironment' and -- 'commentPackageEnvironment'. commonPackageEnvironmentConfig :: FilePath -> SavedConfig @@ -384,14 +362,16 @@ tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do -- | Create a new package environment file, replacing the existing one if it -- exists. Note that the path parameters should point to existing directories. +-- Returns the created environment. createPackageEnvironmentFile :: Verbosity -> FilePath -> FilePath -> Compiler -> Platform - -> IO () + -> IO PackageEnvironment createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile compiler platform = do notice verbosity $ "Writing a default package environment file to " ++ pkgEnvFile initialPkgEnv <- initialPackageEnvironment sandboxDir compiler platform writePackageEnvironmentFile pkgEnvFile initialPkgEnv + return initialPkgEnv -- | Descriptions of all fields in the package environment file. pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment] diff --git a/cabal-install/Distribution/Client/Sandbox/Types.hs b/cabal-install/Distribution/Client/Sandbox/Types.hs index 9396ce3b0bd..7a74ca2eaa1 100644 --- a/cabal-install/Distribution/Client/Sandbox/Types.hs +++ b/cabal-install/Distribution/Client/Sandbox/Types.hs @@ -10,11 +10,12 @@ module Distribution.Client.Sandbox.Types ( UseSandbox(..), isUseSandbox, whenUsingSandbox, - SandboxPackageInfo(..) + SandboxPackageInfo(..), SandboxMetadata(..) ) where import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Client.Types (SourcePackage) +import Distribution.Client.Sandbox.PackageEnvironment (PackageEnvironment(..)) #if !MIN_VERSION_base(4,8,0) import Data.Monoid @@ -22,7 +23,7 @@ import Data.Monoid import qualified Data.Set as S -- | Are we using a sandbox? -data UseSandbox = UseSandbox FilePath | NoSandbox +data UseSandbox = UseSandbox SandboxMetadata | NoSandbox instance Monoid UseSandbox where mempty = NoSandbox @@ -40,8 +41,8 @@ isUseSandbox NoSandbox = False -- | Execute an action only if we're in a sandbox, feeding to it the path to the -- sandbox directory. whenUsingSandbox :: UseSandbox -> (FilePath -> IO ()) -> IO () -whenUsingSandbox NoSandbox _ = return () -whenUsingSandbox (UseSandbox sandboxDir) act = act sandboxDir +whenUsingSandbox NoSandbox _ = return () +whenUsingSandbox (UseSandbox sandboxMetadata) act = act (smSandboxDirectory sandboxMetadata) -- | Data about the packages installed in the sandbox that is passed from -- 'reinstallAddSourceDeps' to the solver. @@ -62,3 +63,11 @@ data SandboxPackageInfo = SandboxPackageInfo { allAddSourceDependencies :: !(S.Set FilePath) -- ^ A set of paths to all add-source dependencies, for convenience. } + +-- | Metadata about the sandbox +-- FIXME: doc comments for individual fields +data SandboxMetadata = SandboxMetadata { + smSandboxDirectory :: !FilePath, + smSandboxConfigFile :: !FilePath, + smPackageEnvironment :: !PackageEnvironment + } diff --git a/cabal-install/Distribution/Client/Utils.hs b/cabal-install/Distribution/Client/Utils.hs index 901540d8930..59ff7cfa4c5 100644 --- a/cabal-install/Distribution/Client/Utils.hs +++ b/cabal-install/Distribution/Client/Utils.hs @@ -6,6 +6,7 @@ module Distribution.Client.Utils ( MergeResult(..) , inDir, determineNumJobs, numberOfProcessors , removeExistingFile , withTempFileName + , parentsOfCurrentDirectory , makeAbsoluteToCwd, filePathToByteString , byteStringToFilePath, tryCanonicalizePath , canonicalizePathNoThrow @@ -31,7 +32,7 @@ import Text.Read ( readMaybe ) #endif import Data.List - ( isPrefixOf, sortBy, groupBy ) + ( isPrefixOf, sortBy, groupBy, inits ) import Data.Word ( Word8, Word32) import Foreign.C.Types ( CInt(..) ) @@ -41,7 +42,7 @@ import System.Directory ( canonicalizePath, doesFileExist, getCurrentDirectory , removeFile, setCurrentDirectory ) import System.FilePath - ( (), isAbsolute ) + ( (), isAbsolute, splitDirectories, joinPath ) import System.IO ( Handle, hClose, openTempFile #if MIN_VERSION_base(4,4,0) @@ -122,6 +123,14 @@ withTempFileName tmpDir template action = (\(name, _) -> removeExistingFile name) (\(name, h) -> hClose h >> action name) +-- | Return a list of all the parent directories of the current +-- directory, in order of current directory, parent directory, +-- its parent, etc. +parentsOfCurrentDirectory :: IO [FilePath] +parentsOfCurrentDirectory = do + d <- getCurrentDirectory + return $ map joinPath $ reverse $ inits $ splitDirectories d + -- | Executes the action in the specified directory. inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs index f2b3606e86e..c488da61dbb 100644 --- a/cabal-install/Main.hs +++ b/cabal-install/Main.hs @@ -86,7 +86,6 @@ import Distribution.Client.Sandbox (sandboxInit ,sandboxHcPkg ,dumpPackageEnvironment - ,getSandboxConfigFilePath ,loadConfigOrSandboxConfig ,findSavedDistPref ,initPackageDBIfNeeded @@ -95,8 +94,8 @@ import Distribution.Client.Sandbox (sandboxInit ,WereDepsReinstalled(..) ,maybeReinstallAddSourceDeps ,tryGetIndexFilePath + ,getSandboxMetadata ,sandboxBuildDir - ,updateSandboxConfigFileFlag ,updateInstallDirs ,configCompilerAux' @@ -105,7 +104,7 @@ import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB ,userPackageEnvironmentFile) import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) -import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) +import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox, SandboxMetadata(..)) import Distribution.Client.Types (Password (..)) import Distribution.Client.Init (initCabal) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade @@ -202,7 +201,8 @@ mainWorker args = topHandler $ CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs CommandReadyToGo action -> do - globalFlags' <- updateSandboxConfigFileFlag globalFlags + let globalFlags' = globalFlags -- FIXME: Hmm... this is an interesting one: globalFlags' <- updateSandboxConfigFileFlag globalFlags + action globalFlags' where @@ -304,9 +304,10 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do -- may need to create a sandbox-local package DB for this compiler and add a -- timestamp record for this compiler to the timestamp file. let configFlags'' = case useSandbox of - NoSandbox -> configFlags' - (UseSandbox sandboxDir) -> setPackageDB sandboxDir - comp platform configFlags' + NoSandbox -> configFlags' + (UseSandbox sandboxMetadata) -> + let sandboxDir = smSandboxDirectory sandboxMetadata in + setPackageDB sandboxDir comp platform configFlags' whenUsingSandbox useSandbox $ \sandboxDir -> do initPackageDBIfNeeded verbosity configFlags'' comp conf @@ -536,11 +537,14 @@ reconfigure verbosity flagDistPref addConfigFlags extraArgs globalFlags } flags = mconcat [configFlags, addConfigFlags, distVerbFlags] + -- Figure out where the sandbox config file is + let (UseSandbox sandboxMetadata) = useSandbox -- FIXME: Refutable match! the old code used current directory here! + -- Was the sandbox created after the package was already configured? We -- may need to skip reinstallation of add-source deps and force -- reconfigure. let buildConfig = localBuildInfoFile distPref - sandboxConfig <- getSandboxConfigFilePath globalFlags + let sandboxConfig = smSandboxConfigFile sandboxMetadata isSandboxConfigNewer <- sandboxConfig `existsAndIsMoreRecentThan` buildConfig @@ -684,8 +688,8 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags) -- mode of operation, so we stick to it for consistency. let sandboxDistPref = case useSandbox of - NoSandbox -> NoFlag - UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir + NoSandbox -> NoFlag + UseSandbox sandboxMetadata -> Flag $ sandboxBuildDir $ smSandboxDirectory sandboxMetadata distPref <- findSavedDistPref config (configDistPref configFlags `mappend` sandboxDistPref) @@ -708,8 +712,8 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags) -- may need to create a sandbox-local package DB for this compiler and add a -- timestamp record for this compiler to the timestamp file. configFlags'' <- case useSandbox of - NoSandbox -> configAbsolutePaths $ configFlags' - (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform configFlags' + NoSandbox -> configAbsolutePaths $ configFlags' + (UseSandbox sandboxMetadata) -> return $ setPackageDB (smSandboxDirectory sandboxMetadata) comp platform configFlags' whenUsingSandbox useSandbox $ \sandboxDir -> do initPackageDBIfNeeded verbosity configFlags'' comp conf' @@ -1128,23 +1132,30 @@ sandboxAction sandboxFlags extraArgs globalFlags = do ("add-source":extra) -> do when (noExtraArgs extra) $ die "The 'sandbox add-source' command expects at least one argument" - sandboxAddSource verbosity extra sandboxFlags globalFlags + sandboxMetadata <- getSandboxMetadata verbosity globalFlags -- FIXME: calls here should perhaps be "inlined" into each of the functions... (of course then we're back to GlobalFlags for those functions, but perhaps that's OK?) + sandboxAddSource verbosity extra sandboxFlags sandboxMetadata ("delete-source":extra) -> do when (noExtraArgs extra) $ die ("The 'sandbox delete-source' command expects " ++ "at least one argument") - sandboxDeleteSource verbosity extra sandboxFlags globalFlags - ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags + sandboxMetadata <- getSandboxMetadata verbosity globalFlags + sandboxDeleteSource verbosity extra sandboxMetadata + ["list-sources"] -> do + sandboxMetadata <- getSandboxMetadata verbosity globalFlags + sandboxListSources verbosity sandboxMetadata -- More advanced commands. ("hc-pkg":extra) -> do when (noExtraArgs extra) $ die $ "The 'sandbox hc-pkg' command expects at least one argument" - sandboxHcPkg verbosity sandboxFlags globalFlags extra + sandboxMetadata <- getSandboxMetadata verbosity globalFlags + sandboxHcPkg verbosity sandboxMetadata extra ["buildopts"] -> die "Not implemented!" -- Hidden commands. - ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags + ["dump-pkgenv"] -> do + sandboxMetadata <- getSandboxMetadata verbosity globalFlags + dumpPackageEnvironment sandboxMetadata -- Error handling. [] -> die $ "Please specify a subcommand (see 'help sandbox')"