diff --git a/Cabal/Distribution/Simple/SrcDist.hs b/Cabal/Distribution/Simple/SrcDist.hs index 71cb5b300b2..9698d5e0e00 100644 --- a/Cabal/Distribution/Simple/SrcDist.hs +++ b/Cabal/Distribution/Simple/SrcDist.hs @@ -54,7 +54,7 @@ module Distribution.Simple.SrcDist ( -- * The top level action sdist, - -- * Actual impl of 'sdist', for reuse by 'cabal sdist' + -- * Actual implemenation of 'sdist', for reuse by 'cabal sdist' CreateArchiveFun, sdistWith, @@ -69,6 +69,14 @@ module Distribution.Simple.SrcDist ( snapshotVersion, dateToSnapshotNumber, + -- * Extracting the source files + findSetupFile, + findMainExeFile, + findIncludeFile, + filterAutogenModule, + allSourcesBuildInfo, + + -- * Utils copyFileTo ) where @@ -91,7 +99,8 @@ import Distribution.Simple.Utils , withTempDirectory, defaultPackageDesc , die, warn, notice, setupMessage ) import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe) -import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent) +import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes + , preprocessComponent ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withAllComponentsInBuildOrder ) import Distribution.Simple.BuildPaths ( autogenModuleName ) @@ -190,11 +199,7 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do -- move the executables into place withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi - srcMainFile <- do - ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath) - case ppFile of - Nothing -> findFile (hsSourceDirs exeBi) mainPath - Just pp -> return pp + srcMainFile <- findMainExeFile exeBi pps mainPath copyFileTo verbosity targetDir srcMainFile -- move the test suites into place @@ -214,7 +219,8 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do copyFileTo verbosity targetDir srcMainFile TestSuiteLibV09 _ m -> do prep [m] bi - TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp + TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " + ++ show tp -- move the benchmarks into place withBenchmark $ \bm -> do @@ -231,8 +237,10 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do Nothing -> findFile (hsSourceDirs bi) mainPath Just pp -> return pp copyFileTo verbosity targetDir srcMainFile - BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " ++ show tp + BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " + ++ show tp + -- move the data files into place. forM_ (dataFiles pkg_descr) $ \ filename -> do files <- matchFileGlob (dataDir pkg_descr filename) let dir = takeDirectory (dataDir pkg_descr filename) @@ -240,6 +248,7 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do sequence_ [ installOrdinaryFile verbosity file (targetDir file) | file <- files ] + -- move the license file and extra src files into place. when (not (null (licenseFile pkg_descr))) $ copyFileTo verbosity targetDir (licenseFile pkg_descr) forM_ (extraSrcFiles pkg_descr ++ extraHtmlFiles pkg_descr) $ \ fpath -> do @@ -256,7 +265,7 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do withLib $ \ l -> do let lbi = libBuildInfo l relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) - incs <- mapM (findInc relincdirs) (installIncludes lbi) + incs <- mapM (findIncludeFile relincdirs) (installIncludes lbi) forM_ incs $ \(_,fpath) -> copyFileTo verbosity targetDir fpath -- if the package was configured then we can run platform independent @@ -269,19 +278,66 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do _ -> return () -- setup isn't listed in the description file. - hsExists <- doesFileExist "Setup.hs" - lhsExists <- doesFileExist "Setup.lhs" - if hsExists then copyFileTo verbosity targetDir "Setup.hs" - else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs" - else writeUTF8File (targetDir "Setup.hs") $ unlines [ - "import Distribution.Simple", - "main = defaultMain"] + mSetupFile <- findSetupFile + case mSetupFile of + Just setupFile -> copyFileTo verbosity targetDir setupFile + Nothing -> do writeUTF8File (targetDir "Setup.hs") $ unlines [ + "import Distribution.Simple", + "main = defaultMain"] + -- the description file itself descFile <- defaultPackageDesc verbosity installOrdinaryFile verbosity descFile (targetDir descFile) where - pkg_descr = mapLib filterAutogenModuleLib $ mapAllBuildInfo filterAutogenModuleBI pkg_descr0 + pkg_descr = filterAutogenModule pkg_descr0 + + -- We have to deal with all libs and executables, so we have local + -- versions of these functions that ignore the 'buildable' attribute: + withLib action = maybe (return ()) action (library pkg_descr) + withExe action = mapM_ action (executables pkg_descr) + withTest action = mapM_ action (testSuites pkg_descr) + withBenchmark action = mapM_ action (benchmarks pkg_descr) + +-- | Find the setup script file, if it exists. +findSetupFile :: IO (Maybe FilePath) +findSetupFile = do + hsExists <- doesFileExist setupHs + lhsExists <- doesFileExist setupLhs + if hsExists + then return (Just setupHs) + else if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "Setup.hs" + setupLhs = "Setup.lhs" + +-- | Find the main executable file. +findMainExeFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath +findMainExeFile exeBi pps mainPath = do + ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) + (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs exeBi) mainPath + Just pp -> return pp + +-- | Given a list of include paths, try to find the include file named +-- @f@. Return the name of the file and the full path, or exit with error if +-- there's no such file. +findIncludeFile :: [FilePath] -> String -> IO (String, FilePath) +findIncludeFile [] f = die ("can't find include file " ++ f) +findIncludeFile (d:ds) f = do + let path = (d f) + b <- doesFileExist path + if b then return (f,path) else findIncludeFile ds f + +-- | Remove the auto-generated module ('Paths_*') from 'exposed-modules' and +-- 'other-modules'. +filterAutogenModule :: PackageDescription -> PackageDescription +filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $ + mapAllBuildInfo filterAutogenModuleBI pkg_descr0 + where mapLib f pkg = pkg { library = fmap f (library pkg) } filterAutogenModuleLib lib = lib { exposedModules = filter (/=autogenModule) (exposedModules lib) @@ -291,19 +347,6 @@ prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do } autogenModule = autogenModuleName pkg_descr0 - findInc [] f = die ("can't find include file " ++ f) - findInc (d:ds) f = do - let path = (d f) - b <- doesFileExist path - if b then return (f,path) else findInc ds f - - -- We have to deal with all libs and executables, so we have local - -- versions of these functions that ignore the 'buildable' attribute: - withLib action = maybe (return ()) action (library pkg_descr) - withExe action = mapM_ action (executables pkg_descr) - withTest action = mapM_ action (testSuites pkg_descr) - withBenchmark action = mapM_ action (benchmarks pkg_descr) - -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. @@ -313,7 +356,8 @@ prepareSnapshotTree :: Verbosity -- ^verbosity -> Maybe LocalBuildInfo -> FilePath -- ^dist dir -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> [PPSuffixHandler] -- ^extra preprocessors (includes + -- suffixes) -> IO () prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do prepareTree verbosity pkg mb_lbi distPref targetDir pps @@ -392,33 +436,43 @@ createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do return tarBallFilePath -- |Move the sources into place based on buildInfo -prepareDir :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^dist dir - -> FilePath -- ^TargetPrefix +prepareDir :: Verbosity -- ^ verbosity + -> PackageDescription -- ^ info from the cabal file + -> FilePath -- ^ dist dir + -> FilePath -- ^ TargetPrefix -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> [ModuleName] -- ^Exposed modules + -> [ModuleName] -- ^ Exposed modules -> BuildInfo -> IO () prepareDir verbosity _pkg _distPref inPref pps modules bi - = do let searchDirs = hsSourceDirs bi - sources <- sequence - [ let file = ModuleName.toFilePath module_ - in findFileWithExtension suffixes searchDirs file - >>= maybe (notFound module_) return - | module_ <- modules ++ otherModules bi ] - bootFiles <- sequence - [ let file = ModuleName.toFilePath module_ - fileExts = ["hs-boot", "lhs-boot"] - in findFileWithExtension fileExts (hsSourceDirs bi) file - | module_ <- modules ++ otherModules bi ] - - let allSources = sources ++ catMaybes bootFiles ++ cSources bi + = do allSources <- allSourcesBuildInfo bi pps modules installOrdinaryFiles verbosity inPref (zip (repeat []) allSources) - where suffixes = ppSuffixes pps ++ ["hs", "lhs"] - notFound m = die $ "Error: Could not find module: " ++ display m - ++ " with any suffix: " ++ show suffixes +-- | Given a buildinfo, return the names of all source files. +allSourcesBuildInfo :: BuildInfo + -> [PPSuffixHandler] -- ^ Extra preprocessors + -> [ModuleName] -- ^ Exposed modules + -> IO [FilePath] +allSourcesBuildInfo bi pps modules = do + let searchDirs = hsSourceDirs bi + sources <- sequence + [ let file = ModuleName.toFilePath module_ + in findFileWithExtension suffixes searchDirs file + >>= maybe (notFound module_) return + | module_ <- modules ++ otherModules bi ] + bootFiles <- sequence + [ let file = ModuleName.toFilePath module_ + fileExts = ["hs-boot", "lhs-boot"] + in findFileWithExtension fileExts (hsSourceDirs bi) file + | module_ <- modules ++ otherModules bi ] + + return $ sources ++ catMaybes bootFiles ++ cSources bi + + where + suffixes = ppSuffixes pps ++ ["hs", "lhs"] + notFound m = die $ "Error: Could not find module: " ++ display m + ++ " with any suffix: " ++ show suffixes + copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () copyFileTo verbosity dir file = do diff --git a/cabal-install/Distribution/Client/Sandbox.hs b/cabal-install/Distribution/Client/Sandbox.hs index 612939b0bd4..0f4d2bca080 100644 --- a/cabal-install/Distribution/Client/Sandbox.hs +++ b/cabal-install/Distribution/Client/Sandbox.hs @@ -22,8 +22,8 @@ module Distribution.Client.Sandbox ( loadConfigOrSandboxConfig, initPackageDBIfNeeded, maybeWithSandboxDirOnSearchPath, - installAddSourceDeps, - maybeInstallAddSourceDeps, + reinstallAddSourceDeps, + maybeReinstallAddSourceDeps, -- FIXME: move somewhere else configPackageDB', configCompilerAux' @@ -33,6 +33,9 @@ import Distribution.Client.Setup ( SandboxFlags(..), ConfigFlags(..), GlobalFlags(..), InstallFlags(..) , defaultConfigExFlags, defaultInstallFlags, defaultSandboxLocation , globalRepos ) +import Distribution.Client.Sandbox.Timestamp ( withRemoveTimestamps + , withUpdateTimestamps + , withModifiedDeps ) import Distribution.Client.Config ( SavedConfig(..), loadConfig ) import Distribution.Client.Dependency ( foldProgress ) import Distribution.Client.Install ( InstallArgs, @@ -67,9 +70,9 @@ import Distribution.Verbosity ( Verbosity, lessVerbose ) import Distribution.Compat.Env ( lookupEnv, setEnv ) import qualified Distribution.Client.Index as Index import qualified Distribution.Simple.Register as Register -import Control.Exception ( bracket_ ) +import Control.Exception ( assert, bracket_ ) import Control.Monad ( unless, when ) -import Data.List ( delete ) +import Data.List ( (\\), delete ) import Data.Monoid ( mempty, mappend ) import System.Directory ( doesDirectoryExist , getCurrentDirectory @@ -215,21 +218,31 @@ sandboxDelete verbosity _sandboxFlags globalFlags = do sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags -> IO () sandboxAddSource verbosity buildTreeRefs _sandboxFlags globalFlags = do - (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity - (globalConfigFile globalFlags) - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity + (globalConfigFile globalFlags) + indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) - Index.addBuildTreeRefs verbosity indexFile buildTreeRefs + withUpdateTimestamps sandboxDir $ \_ -> do + -- FIXME: path canonicalisation is done in addBuildTreeRefs, but we do it + -- twice because of the timestamps file. + buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs + Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' + return buildTreeRefs' -- | 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 - (globalConfigFile globalFlags) - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity + (globalConfigFile globalFlags) + indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) - Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs + withRemoveTimestamps sandboxDir $ \_ -> do + -- FIXME: path canonicalisation is done in addBuildTreeRefs, but we do it + -- twice because of the timestamps file. + buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs + Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs' + return buildTreeRefs' -- | Entry point for the 'cabal sandbox list-sources' command. sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags @@ -298,65 +311,70 @@ maybeWithSandboxDirOnSearchPath NoSandbox act = act maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act = withSandboxBinDirOnSearchPath sandboxDir $ act --- | (Re)install all add-source dependencies of the current package into the --- sandbox. -installAddSourceDeps :: Verbosity -> SavedConfig -> Flag (Maybe Int) - -> FilePath -> GlobalFlags - -> IO () -installAddSourceDeps verbosity config numJobsFlag sandboxDir globalFlags = do +-- | Reinstall those add-source dependencies that have been modified since +-- we've last installed them. +reinstallAddSourceDeps :: Verbosity -> SavedConfig -> Flag (Maybe Int) + -> FilePath -> GlobalFlags + -> IO () +reinstallAddSourceDeps verbosity config numJobsFlag sandboxDir globalFlags = do indexFile <- tryGetIndexFilePath config buildTreeRefs <- Index.listBuildTreeRefs verbosity indexFile - unless (null buildTreeRefs) $ do - notice verbosity "Installing add-source dependencies..." - let targetNames = (".":buildTreeRefs) - targetsToPrune = [UserTargetLocalDir "."] - configFlags = savedConfigureFlags config - configExFlags = defaultConfigExFlags `mappend` - savedConfigureExFlags config - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config - installFlags = installFlags' { - installNumJobs = installNumJobs installFlags' `mappend` numJobsFlag } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - - (comp, platform, conf) <- configCompilerAux' configFlags - targets <- readUserTargets verbosity targetNames - - let args :: InstallArgs - args = ((configPackageDB' configFlags ForceGlobalInstall) - ,(globalRepos globalFlags') - ,comp, platform, conf - ,globalFlags', configFlags, configExFlags, installFlags - ,mempty) - - logMsg message rest = debugNoWrap verbosity message >> rest - - -- Using the low-level install interface instead of the high-level 'install' - -- action allows us to make changes to the install plan before processing - -- it. Here we need to prune the "." target from the install plan. The same - -- mechanism is used to implement 'install --only-dependencies'. - withSandboxBinDirOnSearchPath sandboxDir $ do - installContext@(_,sourcePkgDb,_,_) <- - makeInstallContext verbosity args targets - - toPrune <- resolveUserTargets verbosity - (fromFlag $ globalWorldFile globalFlags') - (packageIndex sourcePkgDb) - targetsToPrune - - installPlan <- foldProgress logMsg die return =<< - (fmap (\p -> p >>= if not . null $ targetsToPrune - then pruneInstallPlan toPrune - else return) - $ makeInstallPlan verbosity args installContext) - - processInstallPlan verbosity args installContext installPlan - --- | Check if a sandbox is present and call @installAddSourceDeps@ in that case. -maybeInstallAddSourceDeps :: Verbosity -> Flag (Maybe Int) -> GlobalFlags + withModifiedDeps verbosity sandboxDir $ \modifiedDeps -> do + assert (null $ modifiedDeps \\ buildTreeRefs) (return ()) + unless (null modifiedDeps) $ do + notice verbosity "Installing add-source dependencies..." + let targetNames = (".":modifiedDeps) + targetsToPrune = [UserTargetLocalDir "."] + configFlags = savedConfigureFlags config + configExFlags = defaultConfigExFlags `mappend` + savedConfigureExFlags config + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config + installFlags = installFlags' { + installNumJobs = installNumJobs installFlags' `mappend` numJobsFlag + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + + (comp, platform, conf) <- configCompilerAux' configFlags + targets <- readUserTargets verbosity targetNames + + let args :: InstallArgs + args = ((configPackageDB' configFlags ForceGlobalInstall) + ,(globalRepos globalFlags') + ,comp, platform, conf + ,globalFlags', configFlags, configExFlags, installFlags + ,mempty) + + logMsg message rest = debugNoWrap verbosity message >> rest + + -- Using the low-level install interface instead of the high-level + -- 'install' action allows us to make changes to the install plan before + -- processing it. Here we need to prune the "." target from the install + -- plan. The same mechanism is used to implement 'install + -- --only-dependencies'. + withSandboxBinDirOnSearchPath sandboxDir $ do + installContext@(_,sourcePkgDb,_,_) <- + makeInstallContext verbosity args targets + + toPrune <- resolveUserTargets verbosity + (fromFlag $ globalWorldFile globalFlags') + (packageIndex sourcePkgDb) + targetsToPrune + + installPlan <- foldProgress logMsg die return =<< + (fmap (\p -> p >>= if not . null $ targetsToPrune + then pruneInstallPlan toPrune + else return) + $ makeInstallPlan verbosity args installContext) + + processInstallPlan verbosity args installContext installPlan + +-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that +-- case. +maybeReinstallAddSourceDeps :: Verbosity -> Flag (Maybe Int) -> GlobalFlags -> IO UseSandbox -maybeInstallAddSourceDeps verbosity numJobsFlag globalFlags = do +maybeReinstallAddSourceDeps verbosity numJobsFlag globalFlags = do currentDir <- getCurrentDirectory pkgEnvType <- classifyPackageEnvironment currentDir case pkgEnvType of @@ -369,7 +387,7 @@ maybeInstallAddSourceDeps verbosity numJobsFlag globalFlags = do UseSandbox d -> d; _ -> error "Distribution.Client.Sandbox.\ \maybeInstallAddSourceDeps: can't happen" - installAddSourceDeps verbosity config numJobsFlag sandboxDir globalFlags + reinstallAddSourceDeps verbosity config numJobsFlag sandboxDir globalFlags return useSandbox -- diff --git a/cabal-install/Distribution/Client/Sandbox/Timestamp.hs b/cabal-install/Distribution/Client/Sandbox/Timestamp.hs new file mode 100644 index 00000000000..e1a67655457 --- /dev/null +++ b/cabal-install/Distribution/Client/Sandbox/Timestamp.hs @@ -0,0 +1,204 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox.Timestamp +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Timestamp file handling (for add-source dependencies). +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox.Timestamp ( + AddSourceTimestamp, + withRemoveTimestamps, + withUpdateTimestamps, + isDepModified, + withModifiedDeps, + ) where + +import Control.Monad (filterM, forM) +import Data.Char (isSpace) +import Data.Maybe (maybeToList) +import Data.List (partition) +import System.Directory (renameFile) +import System.FilePath (isAbsolute, (<.>), ()) + +import Distribution.PackageDescription (BuildInfo (..), + Executable (..), + Library (..), + PackageDescription (..)) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.SrcDist (allSourcesBuildInfo, + filterAutogenModule, + findIncludeFile, + findMainExeFile, + findSetupFile) +import Distribution.Simple.Utils (defaultPackageDesc, die, + findPackageDesc, + matchFileGlob) +import Distribution.Verbosity (Verbosity) + +import Distribution.Client.Utils (inDir) + +import Distribution.Compat.Exception (catchIO) +import Distribution.Compat.Time (EpochTime, getCurTime, + getModTime) + + +-- | Timestamp of an add-source dependency. +type AddSourceTimestamp = (FilePath, EpochTime) + +-- | The 'add-source-timestamps' file keeps the timestamps of all add-source +-- dependencies. It is initially populated by 'sandbox add-source' and kept +-- current by 'reinstallAddSourceDeps'. The user can install add-source deps +-- manually with 'cabal install' after having edited them, so we can err on the +-- side of caution sometimes. +-- FIXME: We should keep this info in the index file, together with build tree +-- refs. +timestampFileName :: FilePath +timestampFileName = "add-source-timestamps" + +-- | Read the timestamp file. Returns an empty list if the file doesn't exist. +readTimestamps :: FilePath -> IO (Maybe [AddSourceTimestamp]) +readTimestamps sandboxDir = do + timestampString <- readFile timestampFile `catchIO` \_ -> return "[]" + case reads timestampString of + [(timestamps, s)] | all isSpace s -> return (Just timestamps) + _ -> return Nothing + where + timestampFile = sandboxDir timestampFileName + +-- | Write the timestamp file, atomically. +writeTimestamps :: FilePath -> [AddSourceTimestamp] -> IO () +writeTimestamps sandboxDir timestamps = do + writeFile timestampTmpFile (show timestamps) + renameFile timestampTmpFile timestampFile + where + timestampFile = sandboxDir timestampFileName + timestampTmpFile = timestampFile <.> "tmp" + +-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps +-- we've reinstalled and a new timestamp value, update the timestamp value for +-- those deps. If there are new paths in the list, add them to the timestamp +-- file with the current date. +updateTimestamps :: EpochTime -> [AddSourceTimestamp] -> [FilePath] + -> [AddSourceTimestamp] +updateTimestamps newTimestamp timestamps paths = + map (\p -> (p, newTimestamp)) newPaths ++ foldr updateTimestamp [] timestamps + where + oldPaths = map fst timestamps + (pathsToUpdate, newPaths) = partition (flip elem oldPaths) paths + + updateTimestamp t@(path, _oldTimestamp) rest + | path `elem` pathsToUpdate = (path, newTimestamp) : rest + | otherwise = t : rest + +-- | Given a list of 'AddSourceTimestamp's and a list of paths to add-source +-- deps we've removed, remove those deps from the list. +removeTimestamps :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp] +removeTimestamps l pathsToRemove = foldr removeTimestamp [] l + where + removeTimestamp t@(path, _oldTimestamp) rest = + if path `elem` pathsToRemove + then rest + else t : rest + +-- | Given an IO action that returns a list of build tree refs, remove those +-- build tree refs to the current time. +withRemoveTimestamps :: FilePath -> ([AddSourceTimestamp] -> IO [FilePath]) + -> IO () +withRemoveTimestamps = withActionOnTimestamps removeTimestamps + +-- | Given an IO action that returns a list of build tree refs, update the +-- timestamps of the returned build tree refs to the current time. +withUpdateTimestamps :: FilePath -> ([AddSourceTimestamp] -> IO [FilePath]) + -> IO () +withUpdateTimestamps sandboxDir act = do + now <- getCurTime + withActionOnTimestamps (updateTimestamps now) sandboxDir act + +-- | Helper for implementing 'withUpdateTimestamps' and 'withRemoveTimestamps'. +withActionOnTimestamps :: ([AddSourceTimestamp] -> [FilePath] + -> [AddSourceTimestamp]) + -> FilePath + -> ([AddSourceTimestamp] -> IO [FilePath]) + -> IO () +withActionOnTimestamps f sandboxDir act = do + mTimestamps <- readTimestamps sandboxDir + case mTimestamps of + Nothing -> die $ "The timestamps file is corrupted. " + ++ "Please delete & recreate the sandbox." + Just timestamps -> do + updatedPaths <- act timestamps + let timestamps' = f timestamps updatedPaths + writeTimestamps sandboxDir timestamps' + +-- | List all source files of a given add-source dependency. Exits with error if +-- something is wrong (e.g. there is no .cabal file in the given directory). +-- FIXME: This function is not thread-safe because of 'inDir'. +allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] +allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do + pkgDesc <- fmap (filterAutogenModule . flattenPackageDescription) + . readPackageDescription verbosity =<< findPackageDesc packageDir + -- NOTE: This is patterned after "Distribution.Simple.SrcDist.prepareTree". + libSources <- withLib pkgDesc $ + \Library { exposedModules = modules, libBuildInfo = libBi } -> + allSourcesBuildInfo libBi pps modules + exeSources <- withExe pkgDesc $ + \Executable { modulePath = mainPath, buildInfo = exeBi } -> do + biSrcs <- allSourcesBuildInfo exeBi pps [] + mainSrc <- findMainExeFile exeBi pps mainPath + return (mainSrc:biSrcs) + + -- We don't care about test and benchmark sources. + + dataFs <- forM (dataFiles pkgDesc) $ \filename -> + matchFileGlob (dataDir pkgDesc filename) + + extraSrcs <- forM (extraSrcFiles pkgDesc) $ \fpath -> + matchFileGlob fpath + + incFiles <- withLib pkgDesc $ \ l -> do + let lbi = libBuildInfo l + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi) + + mSetupFile <- findSetupFile + descFile <- defaultPackageDesc verbosity + + return . map (packageDir ) $ descFile : (maybeToList mSetupFile) + ++ incFiles ++ (concat extraSrcs) ++ (concat dataFs) + ++ (concat exeSources) ++ libSources + + where + -- We have to deal with all libs and executables, so we have local + -- versions of these functions that ignore the 'buildable' attribute: + withLib pkgDesc action = maybe (return []) action (library pkgDesc) + withExe pkgDesc action = mapM action (executables pkgDesc) + + pps = knownSuffixHandlers + + +-- | Has this dependency been modified since we have last looked at it? +isDepModified :: Verbosity -> AddSourceTimestamp -> IO Bool +isDepModified verbosity (packageDir, timestamp) = do + depSources <- allPackageSourceFiles verbosity packageDir + go depSources + + where + go [] = return False + -- TOTHINK: What if the clock jumps backwards at any point? + go (dep:rest) = do modTime <- getModTime dep + if modTime >= timestamp + then return True + else go rest + +-- | Given an IO action, feed to it the list of modified add-source deps and +-- set their timestamps to the current time in the timestamps file. +withModifiedDeps :: Verbosity -> FilePath -> ([FilePath] -> IO ()) -> IO () +withModifiedDeps verbosity sandboxDir act = do + withUpdateTimestamps sandboxDir $ \timestamps -> do + modified <- fmap (map fst) . filterM (isDepModified verbosity) $ timestamps + act modified + return modified diff --git a/cabal-install/Distribution/Client/Tar.hs b/cabal-install/Distribution/Client/Tar.hs index f1c1c7dd303..ead2dfbc200 100644 --- a/cabal-install/Distribution/Client/Tar.hs +++ b/cabal-install/Distribution/Client/Tar.hs @@ -115,7 +115,8 @@ extractTarGzFile :: FilePath -- ^ Destination directory -> FilePath -- ^ Tarball -> IO () extractTarGzFile dir expected tar = - unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar + unpack dir . checkTarbomb expected . read + . GZipUtils.maybeDecompress =<< BS.readFile tar -- -- * Entry type @@ -651,7 +652,8 @@ getChars :: Int64 -> Int64 -> ByteString -> String getChars off len = BS.Char8.unpack . getBytes off len getString :: Int64 -> Int64 -> ByteString -> String -getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len +getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') + . getBytes off len data Partial a = Error String | Ok a diff --git a/cabal-install/Distribution/Client/Utils.hs b/cabal-install/Distribution/Client/Utils.hs index e5976fefacb..3f1d559eb1f 100644 --- a/cabal-install/Distribution/Client/Utils.hs +++ b/cabal-install/Distribution/Client/Utils.hs @@ -75,7 +75,7 @@ moreRecentFile a b = do return (ta > tb) -- | Executes the action in the specified directory. -inDir :: Maybe FilePath -> IO () -> IO () +inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m inDir (Just d) m = do old <- getCurrentDirectory diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs index 763924568b6..3023a3a6737 100644 --- a/cabal-install/Main.hs +++ b/cabal-install/Main.hs @@ -79,7 +79,7 @@ import Distribution.Client.Sandbox (sandboxInit ,loadConfigOrSandboxConfig ,initPackageDBIfNeeded ,maybeWithSandboxDirOnSearchPath - ,maybeInstallAddSourceDeps + ,maybeReinstallAddSourceDeps ,configCompilerAux' ,configPackageDB') @@ -241,8 +241,8 @@ buildAction buildFlags extraArgs globalFlags = do (buildDistPref buildFlags) verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - -- If we're in a sandbox, (re)install all add-source dependencies. - useSandbox <- maybeInstallAddSourceDeps verbosity + -- If we're in a sandbox, reinstall the updated add-source dependencies. + useSandbox <- maybeReinstallAddSourceDeps verbosity (buildNumJobs buildFlags) globalFlags -- Calls 'configureAction' to do the real work, so nothing special has to be @@ -457,8 +457,8 @@ testAction testFlags extraArgs globalFlags = do | fromFlagOrDefault False (configTests flags) = Nothing | otherwise = Just "Re-configuring with test suites enabled." - -- If we're in a sandbox, (re)install all add-source dependencies. - useSandbox <- maybeInstallAddSourceDeps verbosity + -- If we're in a sandbox, reinstall the updated add-source dependencies. + useSandbox <- maybeReinstallAddSourceDeps verbosity (testNumJobs testFlags) globalFlags reconfigure verbosity distPref addConfigFlags [] globalFlags checkFlags @@ -480,8 +480,8 @@ benchmarkAction benchmarkFlags extraArgs globalFlags = do | fromFlagOrDefault False (configBenchmarks flags) = Nothing | otherwise = Just "Re-configuring with benchmarks enabled." - -- If we're in a sandbox, (re)install all add-source dependencies. - useSandbox <- maybeInstallAddSourceDeps verbosity + -- If we're in a sandbox, reinstall the updated add-source dependencies. + useSandbox <- maybeReinstallAddSourceDeps verbosity (benchmarkNumJobs benchmarkFlags) globalFlags reconfigure verbosity distPref addConfigFlags [] globalFlags checkFlags @@ -630,8 +630,8 @@ runAction buildFlags extraArgs globalFlags = do distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (buildDistPref buildFlags) - -- If we're in a sandbox, (re)install all add-source dependencies. - useSandbox <- maybeInstallAddSourceDeps verbosity + -- If we're in a sandbox, reinstall the updated add-source dependencies. + useSandbox <- maybeReinstallAddSourceDeps verbosity (buildNumJobs buildFlags) globalFlags reconfigure verbosity distPref mempty [] globalFlags (const Nothing) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index f9c884078bb..d2067954e2d 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -92,6 +92,7 @@ executable cabal Distribution.Client.ParseUtils Distribution.Client.Run Distribution.Client.Sandbox + Distribution.Client.Sandbox.Timestamp Distribution.Client.Setup Distribution.Client.SetupWrapper Distribution.Client.SrcDist