From ae456ceba4c7386fe8e24d41d0f98616051a5e69 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@community.haskell.org>
Date: Tue, 15 May 2018 16:15:06 +0100
Subject: [PATCH] Hacking on improved VCS support
This patch covers a new VCS abstraction with corresponding tests. It
also re-implements the get command in terms of the VCS and adds unit
tests (including optional network tests).
This does slightly change the behaviour of the get command: instead of
looking for which VCSs are available on the system and then choosing
which repo to try and get, we instead pick a preferred repo and then we
look for the corresponding VCS and fail if it's not available. In
practice this difference does not matter because we don't have multiple
repos for the same package using different VCSs.
---
cabal-install/Distribution/Client/Get.hs | 326 ++++-----
cabal-install/Distribution/Client/VCS.hs | 559 ++++++++++++++
cabal-install/cabal-install.cabal | 4 +
.../UnitTests/Distribution/Client/Get.hs | 222 ++++++
.../UnitTests/Distribution/Client/VCS.hs | 691 ++++++++++++++++++
cabal-install/tests/UnitTests/Options.hs | 13 +-
6 files changed, 1626 insertions(+), 189 deletions(-)
create mode 100644 cabal-install/Distribution/Client/VCS.hs
create mode 100644 cabal-install/tests/UnitTests/Distribution/Client/Get.hs
create mode 100644 cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs
index c8f1f6c8b8..e94e304be5 100644
--- a/cabal-install/Distribution/Client/Get.hs
+++ b/cabal-install/Distribution/Client/Get.hs
@@ -14,7 +14,10 @@
-----------------------------------------------------------------------------
module Distribution.Client.Get (
- get
+ get,
+ forkPackages,
+ ForkException(..),
+ forkPackagesRepo,
) where
import Prelude ()
@@ -25,39 +28,33 @@ import Distribution.Package
import Distribution.Simple.Setup
( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.Utils
- ( notice, die', info, rawSystemExitCode, writeFileAtomic )
+ ( notice, die', info, writeFileAtomic )
import Distribution.Verbosity
( Verbosity )
-import Distribution.Text(display)
+import Distribution.Text (display)
import qualified Distribution.PackageDescription as PD
+import Distribution.Simple.Program
+ ( programName )
import Distribution.Client.Setup
( GlobalFlags(..), GetFlags(..), RepoContext(..) )
import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.Dependency
+import Distribution.Client.VCS
import Distribution.Client.FetchUtils
import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackagesAtIndexState )
-import Distribution.Client.Compat.Process
- ( readProcessWithExitCode )
-import Distribution.Compat.Exception
- ( catchIO )
-
import Distribution.Solver.Types.SourcePackage
import Control.Exception
- ( finally )
+ ( Exception(..), catch, throwIO )
import Control.Monad
- ( forM_, mapM_ )
-import qualified Data.Map
-import Data.Ord
- ( comparing )
+ ( mapM, forM_, mapM_ )
+import qualified Data.Map as Map
import System.Directory
- ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
- , getCurrentDirectory, setCurrentDirectory
- )
+ ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )
import System.Exit
( ExitCode(..) )
import System.FilePath
@@ -108,12 +105,10 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
prefix = fromFlagOrDefault "" (getDestDir getFlags)
+ kind = fromFlag . getSourceRepository $ getFlags
fork :: [UnresolvedSourcePackage] -> IO ()
- fork pkgs = do
- let kind = fromFlag . getSourceRepository $ getFlags
- branchers <- findUsableBranchers
- mapM_ (forkPackage verbosity branchers prefix kind) pkgs
+ fork = forkPackages verbosity prefix kind
unpack :: [UnresolvedSourcePackage] -> IO ()
unpack pkgs = do
@@ -143,6 +138,7 @@ checkTarget verbosity target = case target of
UserTargetLocalCabalFile file -> die' verbosity (notTarball file)
_ -> return ()
where
+ notTarball :: String -> String
notTarball t =
"The 'get' command is for tarball packages. "
++ "The target '" ++ t ++ "' is not a tarball."
@@ -181,171 +177,125 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do
-- * Forking the source repository
-- ------------------------------------------------------------
-data BranchCmd = BranchCmd (Verbosity -> FilePath -> IO ExitCode)
-
-data Brancher = Brancher
- { brancherBinary :: String
- , brancherBuildCmd :: PD.SourceRepo -> Maybe BranchCmd
- }
-
--- | The set of all supported branch drivers.
-allBranchers :: [(PD.RepoType, Brancher)]
-allBranchers =
- [ (PD.Bazaar, branchBzr)
- , (PD.Darcs, branchDarcs)
- , (PD.Git, branchGit)
- , (PD.Mercurial, branchHg)
- , (PD.SVN, branchSvn)
- ]
-
--- | Find which usable branch drivers (selected from 'allBranchers') are
--- available and usable on the local machine.
---
--- Each driver's main command is run with @--help@, and if the child process
--- exits successfully, that brancher is considered usable.
-findUsableBranchers :: IO (Data.Map.Map PD.RepoType Brancher)
-findUsableBranchers = do
- let usable (_, brancher) = flip catchIO (const (return False)) $ do
- let cmd = brancherBinary brancher
- (exitCode, _, _) <- readProcessWithExitCode cmd ["--help"] ""
- return (exitCode == ExitSuccess)
- pairs <- filterM usable allBranchers
- return (Data.Map.fromList pairs)
-
--- | Fork a single package from a remote source repository to the local
--- file system.
-forkPackage :: Verbosity
- -> Data.Map.Map PD.RepoType Brancher
- -- ^ Branchers supported by the local machine.
- -> FilePath
- -- ^ The directory in which new branches or repositories will
- -- be created.
- -> (Maybe PD.RepoKind)
- -- ^ Which repo to choose.
- -> SourcePackage loc
- -- ^ The package to fork.
- -> IO ()
-forkPackage verbosity branchers prefix kind src = do
- let desc = PD.packageDescription (packageDescription src)
- pkgid = display (packageId src)
- pkgname = display (packageName src)
- destdir = prefix </> pkgname
-
- destDirExists <- doesDirectoryExist destdir
- when destDirExists $ do
- die' verbosity ("The directory " ++ show destdir ++ " already exists, not forking.")
-
- destFileExists <- doesFileExist destdir
- when destFileExists $ do
- die' verbosity ("A file " ++ show destdir ++ " is in the way, not forking.")
-
- let repos = PD.sourceRepos desc
- case findBranchCmd branchers repos kind of
- Just (BranchCmd io) -> do
- exitCode <- io verbosity destdir
- case exitCode of
- ExitSuccess -> return ()
- ExitFailure _ -> die' verbosity ("Couldn't fork package " ++ pkgid)
- Nothing -> case repos of
- [] -> die' verbosity ("Package " ++ pkgid
- ++ " does not have any source repositories.")
- _ -> die' verbosity ("Package " ++ pkgid
- ++ " does not have any usable source repositories.")
-
--- | Given a set of possible branchers, and a set of possible source
--- repositories, find a repository that is both 1) likely to be specific to
--- this source version and 2) is supported by the local machine.
-findBranchCmd :: Data.Map.Map PD.RepoType Brancher -> [PD.SourceRepo]
- -> (Maybe PD.RepoKind) -> Maybe BranchCmd
-findBranchCmd branchers allRepos maybeKind = cmd where
- -- Sort repositories by kind, from This to Head to Unknown. Repositories
- -- with equivalent kinds are selected based on the order they appear in
- -- the Cabal description file.
- repos' = sortBy (comparing thisFirst) allRepos
- thisFirst r = case PD.repoKind r of
- PD.RepoThis -> 0 :: Int
- PD.RepoHead -> case PD.repoTag r of
- -- If the type is 'head' but the author specified a tag, they
- -- probably meant to create a 'this' repository but screwed up.
- Just _ -> 0
- Nothing -> 1
- PD.RepoKindUnknown _ -> 2
-
- -- If the user has specified the repo kind, filter out the repositories
- -- she's not interested in.
- repos = maybe repos' (\k -> filter ((==) k . PD.repoKind) repos') maybeKind
-
- repoBranchCmd repo = do
- t <- PD.repoType repo
- brancher <- Data.Map.lookup t branchers
- brancherBuildCmd brancher repo
-
- cmd = listToMaybe (mapMaybe repoBranchCmd repos)
-
--- | Branch driver for Bazaar.
-branchBzr :: Brancher
-branchBzr = Brancher "bzr" $ \repo -> do
- src <- PD.repoLocation repo
- let args dst = case PD.repoTag repo of
- Just tag -> ["branch", src, dst, "-r", "tag:" ++ tag]
- Nothing -> ["branch", src, dst]
- return $ BranchCmd $ \verbosity dst -> do
- notice verbosity ("bzr: branch " ++ show src)
- rawSystemExitCode verbosity "bzr" (args dst)
-
--- | Branch driver for Darcs.
-branchDarcs :: Brancher
-branchDarcs = Brancher "darcs" $ \repo -> do
- src <- PD.repoLocation repo
- let args dst = case PD.repoTag repo of
- Just tag -> ["get", src, dst, "-t", tag]
- Nothing -> ["get", src, dst]
- return $ BranchCmd $ \verbosity dst -> do
- notice verbosity ("darcs: get " ++ show src)
- rawSystemExitCode verbosity "darcs" (args dst)
-
--- | Branch driver for Git.
-branchGit :: Brancher
-branchGit = Brancher "git" $ \repo -> do
- src <- PD.repoLocation repo
- let postClone verbosity dst = case PD.repoTag repo of
- Just t -> do
- cwd <- getCurrentDirectory
- setCurrentDirectory dst
- finally
- (rawSystemExitCode verbosity "git" ["checkout", t])
- (setCurrentDirectory cwd)
- Nothing -> return ExitSuccess
- return $ BranchCmd $ \verbosity dst -> do
- notice verbosity ("git: clone " ++ show src)
- code <- rawSystemExitCode verbosity "git" (["clone", src, dst] ++
- case PD.repoBranch repo of
- Nothing -> []
- Just b -> ["--branch", b])
- case code of
- ExitFailure _ -> return code
- ExitSuccess -> postClone verbosity dst
-
--- | Branch driver for Mercurial.
-branchHg :: Brancher
-branchHg = Brancher "hg" $ \repo -> do
- src <- PD.repoLocation repo
- let branchArgs = case PD.repoBranch repo of
- Just b -> ["--branch", b]
- Nothing -> []
- let tagArgs = case PD.repoTag repo of
- Just t -> ["--rev", t]
- Nothing -> []
- let args dst = ["clone", src, dst] ++ branchArgs ++ tagArgs
- return $ BranchCmd $ \verbosity dst -> do
- notice verbosity ("hg: clone " ++ show src)
- rawSystemExitCode verbosity "hg" (args dst)
-
--- | Branch driver for Subversion.
-branchSvn :: Brancher
-branchSvn = Brancher "svn" $ \repo -> do
- src <- PD.repoLocation repo
- let args dst = ["checkout", src, dst]
- return $ BranchCmd $ \verbosity dst -> do
- notice verbosity ("svn: checkout " ++ show src)
- rawSystemExitCode verbosity "svn" (args dst)
+forkPackages :: Verbosity
+ -> FilePath -- ^ destination dir prefix
+ -> Maybe RepoKind -- ^
+ -> [SourcePackage loc] -- ^ the packages
+ -> IO ()
+forkPackages verbosity destDirPrefix preferredRepoKind =
+ forkPackagesRepo verbosity destDirPrefix preferredRepoKind
+ . map (\pkg -> (packageId pkg, packageSourceRepos pkg))
+ where
+ packageSourceRepos :: SourcePackage loc -> [SourceRepo]
+ packageSourceRepos = PD.sourceRepos
+ . PD.packageDescription
+ . packageDescription
+
+data ForkException =
+ ForkExceptionNoSourceRepos PackageId
+ | ForkExceptionNoSourceReposOfKind PackageId (Maybe RepoKind)
+ | ForkExceptionNoRepoType PackageId SourceRepo
+ | ForkExceptionUnsupportedRepoType PackageId SourceRepo RepoType
+ | ForkExceptionNoRepoLocation PackageId SourceRepo
+ | ForkExceptionDestinationExists PackageId FilePath Bool
+ | ForkExceptionFailedWithExitCode PackageId SourceRepo
+ String ExitCode
+ deriving (Show, Eq)
+
+instance Exception ForkException where
+ displayException (ForkExceptionNoSourceRepos pkgid) =
+ "Cannot fetch a source repository for package " ++ display pkgid
+ ++ ". The package does not specify any source repositories."
+
+ displayException (ForkExceptionNoSourceReposOfKind pkgid repoKind) =
+ "Cannot fetch a source repository for package " ++ display pkgid
+ ++ ". The package does not specify a source repository of the requested "
+ ++ "kind" ++ maybe "." (\k -> " (kind " ++ display k ++ ").") repoKind
+
+ displayException (ForkExceptionNoRepoType pkgid _repo) =
+ "Cannot fetch the source repository for package " ++ display pkgid
+ ++ ". The package's description specifies a source repository but does "
+ ++ "not specify the repository 'type' field (e.g. git, darcs or hg)."
+
+ displayException (ForkExceptionUnsupportedRepoType pkgid _repo repoType) =
+ "Cannot fetch the source repository for package " ++ display pkgid
+ ++ ". The repository type '" ++ display repoType
+ ++ "' is not yet supported."
+
+ displayException (ForkExceptionNoRepoLocation pkgid _repo) =
+ "Cannot fetch the source repository for package " ++ display pkgid
+ ++ ". The package's description specifies a source repository but does "
+ ++ "not specify the repository 'location' field (i.e. the URL)."
+
+ displayException (ForkExceptionDestinationExists pkgid dest isdir) =
+ "Not fetching the source repository for package " ++ display pkgid ++ ". "
+ ++ if isdir then "The destination directory " ++ dest ++ " already exists."
+ else "A file " ++ dest ++ " is in the way."
+
+ displayException (ForkExceptionFailedWithExitCode pkgid repo vcsprogname
+ exitcode) =
+ "Failed to fetch the source repository for package " ++ display pkgid
+ ++ maybe "" (", repository location " ++) (PD.repoLocation repo) ++ " ("
+ ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."
+
+
+forkPackagesRepo :: Verbosity
+ -> FilePath
+ -> Maybe RepoKind
+ -> [(PackageId, [SourceRepo])]
+ -> IO ()
+forkPackagesRepo verbosity destDirPrefix preferredRepoKind pkgrepos = do
+
+ -- Do a bunch of checks and collect the required info
+ pkgrepos' <- mapM (prepareClonePackageRepo
+ preferredRepoKind destDirPrefix) pkgrepos
+
+ -- Configure the VCS drivers for all the repository types we may need
+ vcss <- configureVCSs verbosity $
+ Map.fromList [ (vcsRepoType vcs, vcs)
+ | (_, _, vcs, _, _) <- pkgrepos' ]
+
+ -- Now execute all the required commands for each repo
+ sequence_
+ [ cloneSourceRepo verbosity vcs' repo srcURL destDir
+ `catch` \exitcode ->
+ throwIO (ForkExceptionFailedWithExitCode
+ pkgid repo (programName (vcsProgram vcs)) exitcode)
+ | (pkgid, repo, vcs, srcURL, destDir) <- pkgrepos'
+ , let Just vcs' = Map.lookup (vcsRepoType vcs) vcss
+ ]
+
+
+prepareClonePackageRepo :: Maybe RepoKind
+ -> FilePath
+ -> (PackageId, [SourceRepo])
+ -> IO (PackageId, SourceRepo,
+ VCS Program, String, FilePath)
+prepareClonePackageRepo preferredRepoKind destDirPrefix
+ (pkgid, repos) = do
+ repo <- case selectPackageSourceRepo preferredRepoKind repos of
+ Nothing | null repos -> throwIO (ForkExceptionNoSourceRepos pkgid)
+ Nothing -> throwIO (ForkExceptionNoSourceReposOfKind pkgid
+ preferredRepoKind)
+ Just repo -> return repo
+
+ (vcs, srcURL) <- case selectSourceRepoVCS repo of
+ Right x -> return x
+ Left SourceRepoRepoTypeUnspecified ->
+ throwIO (ForkExceptionNoRepoType pkgid repo)
+
+ Left (SourceRepoRepoTypeUnsupported repoType) ->
+ throwIO (ForkExceptionUnsupportedRepoType pkgid repo repoType)
+
+ Left SourceRepoLocationUnspecified ->
+ throwIO (ForkExceptionNoRepoLocation pkgid repo)
+
+ destDirExists <- doesDirectoryExist destDir
+ destFileExists <- doesFileExist destDir
+ when (destDirExists || destFileExists) $
+ throwIO (ForkExceptionDestinationExists pkgid destDir destDirExists)
+
+ return (pkgid, repo, vcs, srcURL, destDir)
+ where
+ destDir = destDirPrefix </> display (packageName pkgid)
+
diff --git a/cabal-install/Distribution/Client/VCS.hs b/cabal-install/Distribution/Client/VCS.hs
new file mode 100644
index 0000000000..4a3fb1dcb6
--- /dev/null
+++ b/cabal-install/Distribution/Client/VCS.hs
@@ -0,0 +1,559 @@
+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
+module Distribution.Client.VCS (
+ VCS(vcsSyncRepos),
+ vcsRepoType,
+ vcsProgram,
+ SourceRepo,
+ RepoType,
+ RepoKind,
+ Program,
+ ConfiguredProgram,
+-- findVcsCloneInvocation,
+ selectPackageSourceRepo,
+ selectSourceRepoVCS,
+ SourceRepoProblem(..),
+ configureVCS,
+ configureVCSs,
+-- findUsableVCSs,
+ cloneSourceRepo,
+ knownVCSs,
+ vcsBzr,
+ vcsDarcs,
+ vcsGit,
+ vcsHg,
+ vcsSvn,
+ ) where
+
+import Prelude ()
+import Distribution.Client.Compat.Prelude
+
+import Distribution.Types.SourceRepo
+ ( SourceRepo(..), RepoType(..), RepoKind(..) )
+import Distribution.Client.FileMonitor
+ ( MonitorFilePath, monitorDirectoryExistence )
+import Distribution.Client.RebuildMonad
+ ( Rebuild, monitorFiles )
+import Distribution.Verbosity as Verbosity
+ ( Verbosity, normal )
+import Distribution.Simple.Program
+ ( Program(programFindVersion, programName)
+ , ConfiguredProgram(programVersion)
+ , simpleProgram, findProgramVersion
+ , ProgramInvocation(..), programInvocation, runProgramInvocation
+ , ProgramDb, emptyProgramDb, knownPrograms, configureProgram
+ , lookupProgram )
+import Distribution.Version
+ ( mkVersion )
+
+import Control.Monad
+ ( mapM_ )
+import qualified Data.Char as Char
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Set (Set)
+import Data.Ord
+ ( comparing )
+import System.FilePath
+ ( takeDirectory )
+import System.Directory
+ ( doesDirectoryExist )
+
+
+-- | A driver for a version control system, e.g. git, darcs etc.
+--
+data VCS program = VCS {
+ -- | The type of repository this driver is for.
+ vcsRepoType :: RepoType,
+
+ -- | The vcs program itself.
+ -- This is used at type 'Program' and 'ConfiguredProgram'.
+ vcsProgram :: program,
+
+ -- | The program invocation(s) to get\/clone a repository into a fresh
+ -- local directory.
+ vcsCloneRepo :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepo
+ -> FilePath -- ^ Source URL
+ -> FilePath -- ^ Destination directory
+ -> [ProgramInvocation],
+
+ -- | The program invocation(s) to synchronise a whole set of /related/
+ -- repositories with corresponding local directories. Also returns the
+ -- files that the command depends on, for change monitoring.
+ vcsSyncRepos :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepo, FilePath)]
+ -> IO [MonitorFilePath]
+ }
+
+
+-- | The set of all supported VCS drivers.
+--
+knownVCSs :: [VCS Program]
+knownVCSs = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ]
+
+
+-- ------------------------------------------------------------
+-- * Selecting repos and drivers
+-- ------------------------------------------------------------
+
+-- | Pick the 'SourceRepo' to use to get the package sources from.
+--
+-- Note that this does /not/ depend on what 'VCS' drivers we are able to
+-- successfully configure. It is based only on the 'SourceRepo's declared
+-- in the package, and optionally on a preferred 'RepoKind'.
+--
+selectPackageSourceRepo :: Maybe RepoKind
+ -> [SourceRepo]
+ -> Maybe SourceRepo
+selectPackageSourceRepo preferredRepoKind =
+ listToMaybe
+ -- Sort repositories by kind, from This to Head to Unknown. Repositories
+ -- with equivalent kinds are selected based on the order they appear in
+ -- the Cabal description file.
+ . sortBy (comparing thisFirst)
+ -- If the user has specified the repo kind, filter out the repositories
+ -- they're not interested in.
+ . filter (\repo -> maybe True (repoKind repo ==) preferredRepoKind)
+ where
+ thisFirst :: SourceRepo -> Int
+ thisFirst r = case repoKind r of
+ RepoThis -> 0
+ RepoHead -> case repoTag r of
+ -- If the type is 'head' but the author specified a tag, they
+ -- probably meant to create a 'this' repository but screwed up.
+ Just _ -> 0
+ Nothing -> 1
+ RepoKindUnknown _ -> 2
+
+data SourceRepoProblem = SourceRepoRepoTypeUnspecified
+ | SourceRepoRepoTypeUnsupported RepoType
+ | SourceRepoLocationUnspecified
+
+-- | Given a single 'SourceRepo', pick which VCS we should use to fetch it.
+--
+-- It also validates that the 'SourceRepo' specifies a repo location URL, and
+-- returns that URL string.
+--
+selectSourceRepoVCS :: SourceRepo
+ -> Either SourceRepoProblem
+ (VCS Program, String)
+selectSourceRepoVCS = \repo -> do
+ rtype <- repoType repo ?! SourceRepoRepoTypeUnspecified
+ vcs <- Map.lookup rtype knownVCSs' ?! SourceRepoRepoTypeUnsupported rtype
+ url <- repoLocation repo ?! SourceRepoLocationUnspecified
+ return (vcs, url)
+ where
+ a ?! e = maybe (Left e) Right a
+
+ -- The 'knownVCSs' organised by 'RepoType'.
+ knownVCSs' = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- knownVCSs ]
+
+
+{-
+-- | Find which usable VCS drivers (selected from 'knownVCSs') are
+-- available and usable on the local machine for the given 'RepoType's.
+--
+findUsableVCSs :: Verbosity
+ -> Set RepoType -- ^ Which repo types we are interested in.
+ -> IO (Map RepoType (VCS ConfiguredProgram))
+findUsableVCSs verbosity repoTypes = do
+ progdb <- configurePrograms
+ [ vcsProgram vcs
+ | vcs <- knownVCSs
+ , vcsRepoType vcs `Set.member` repoTypes ]
+
+ let vcssByProg = Map.fromList
+ [ (programName (vcsProgram vcs), vcs)
+ | vcs <- knownVCSs ]
+ usableProgs = Map.fromList
+ [ (programName prog, cprog)
+ | (prog, Just cprog) <- knownPrograms progdb ]
+ usableVCSs = reindexByRepoType $
+ Map.intersectionWith
+ (\prog vcs -> vcs { vcsProgram = prog})
+ usableProgs
+ vcssByProg
+
+ return usableVCSs
+ where
+ reindexByRepoType :: Map a (VCS p) -> Map RepoType (VCS p)
+ reindexByRepoType = Map.fromList
+ . map (\vcs -> (vcsRepoType vcs, vcs))
+ . Map.elems
+
+ --TODO: export this from Distribution.Simple.Program.Db
+ configurePrograms :: [Program] -> IO ProgramDb
+ configurePrograms = foldM (flip (configureProgram verbosity)) emptyProgramDb
+-}
+
+configureVCS :: Verbosity
+ -> VCS Program
+ -> IO (Maybe (VCS ConfiguredProgram))
+configureVCS verbosity vcs@VCS{vcsProgram = prog} =
+ selectConfigured <$> configureProgram verbosity prog emptyProgramDb
+ where
+ selectConfigured :: ProgramDb -> Maybe (VCS ConfiguredProgram)
+ selectConfigured = fmap (\prog' -> vcs { vcsProgram = prog' })
+ . lookupProgram prog
+
+--TODO: use requireProgram, we don't need optional configuration
+
+configureVCSs :: Verbosity
+ -> Map RepoType (VCS Program)
+ -> IO (Map RepoType (VCS ConfiguredProgram))
+configureVCSs verbosity vcss =
+ keepConfigured <$> traverse (configureVCS verbosity) vcss
+ where
+ keepConfigured :: Map a (Maybe b) -> Map a b
+ keepConfigured = Map.mapMaybe id
+
+
+-- ------------------------------------------------------------
+-- * Running the driver
+-- ------------------------------------------------------------
+
+-- | Clone a single source repo into a fresh directory, using a configured VCS.
+--
+-- This is for making a new copy, not synchronising an existing copy. It will
+-- fail if the destination directory already exists.
+--
+cloneSourceRepo :: Verbosity
+ -> VCS ConfiguredProgram
+ -> SourceRepo
+ -> String -- ^ Source URL
+ -> FilePath -- ^ Destination directory
+ -> IO ()
+cloneSourceRepo verbosity vcs repo srcurl destdir =
+ mapM_ (runProgramInvocation verbosity) invocations
+ where
+ invocations = vcsCloneRepo vcs verbosity
+ (vcsProgram vcs) repo
+ srcurl destdir
+
+
+-- | Syncronise a set of 'SourceRepo's referring to the same repository with
+-- corresponding local directories. The local directories may or may not
+-- already exist.
+--
+-- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos',
+-- or used across a series of invocations with any local directory must refer
+-- to the /same/ repository. That means it must be the same location but they
+-- can differ in the branch, or tag or subdir.
+--
+-- The reason to allow multiple related 'SourceRepo's is to allow for the
+-- network or storage to be shared between different checkouts of the repo.
+-- For example if a single repo contains multiple packages in different subdirs
+-- and in some project it may make sense to use a different state of the repo
+-- for one subdir compared to another.
+--
+syncSourceRepos :: Verbosity
+ -> VCS ConfiguredProgram
+ -> [(SourceRepo, FilePath)]
+ -> Rebuild ()
+syncSourceRepos _verbosity _vcs _repos = undefined
+
+
+{-
+-- | Given a set of possible VCSs, and a set of possible source
+-- repositories, find a repository that is both 1) likely to be specific to
+-- this source version and 2) is supported by the local machine.
+findVcsCloneInvocation :: Map RepoType (VCS ConfiguredProgram)
+ -> [SourceRepo]
+ -> Maybe RepoKind
+ -> FilePath
+ -> Maybe [ProgramInvocation]
+findVcsCloneInvocation vcss repos maybeKind destdir =
+ listToMaybe
+ [ invocations
+ -- Sort repositories by kind, from This to Head to Unknown. Repositories
+ -- with equivalent kinds are selected based on the order they appear in
+ -- the Cabal description file.
+ | repo <- sortBy (comparing thisFirst) repos
+ -- If the user has specified the repo kind, filter out the repositories
+ -- they're not interested in.
+ , maybe True (repoKind repo ==) maybeKind
+ , Just invocations <- [repoCloneCmds repo]
+ ]
+ where
+ thisFirst :: SourceRepo -> Int
+ thisFirst r = case repoKind r of
+ RepoThis -> 0
+ RepoHead -> case repoTag r of
+ -- If the type is 'head' but the author specified a tag, they
+ -- probably meant to create a 'this' repository but screwed up.
+ Just _ -> 0
+ Nothing -> 1
+ RepoKindUnknown _ -> 2
+
+ repoCloneCmds :: SourceRepo -> Maybe [ProgramInvocation]
+ repoCloneCmds repo = do
+ rtype <- repoType repo
+ srcurl <- repoLocation repo
+ vcs <- Map.lookup rtype vcss
+ return (vcsCloneRepo vcs (vcsProgram vcs) repo srcurl destdir)
+-}
+
+-- ------------------------------------------------------------
+-- * The various VCS drivers
+-- ------------------------------------------------------------
+
+-- | VCS driver for Bazaar.
+--
+vcsBzr :: VCS Program
+vcsBzr =
+ VCS {
+ vcsRepoType = Bazaar,
+ vcsProgram = bzrProgram,
+ vcsCloneRepo,
+ vcsSyncRepos
+ }
+ where
+ vcsCloneRepo :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepo
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
+ vcsCloneRepo verbosity prog repo srcurl destdir =
+ [ programInvocation prog
+ ([branchCmd, srcurl, destdir] ++ tagArgs ++ verboseArg) ]
+ where
+ -- The @get@ command was deprecated in version 2.4 in favour of
+ -- the alias @branch@
+ branchCmd | programVersion prog >= Just (mkVersion [2,4])
+ = "branch"
+ | otherwise = "get"
+
+ tagArgs = case repoTag repo of
+ Nothing -> []
+ Just tag -> ["-r", "tag:" ++ tag]
+ verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+
+ vcsSyncRepos :: Verbosity -> ConfiguredProgram
+ -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath]
+ vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr"
+
+bzrProgram :: Program
+bzrProgram = (simpleProgram "bzr") {
+ programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff"
+ (_:_:ver:_) -> ver
+ _ -> ""
+ }
+
+
+-- | VCS driver for Darcs.
+--
+vcsDarcs :: VCS Program
+vcsDarcs =
+ VCS {
+ vcsRepoType = Darcs,
+ vcsProgram = darcsProgram,
+ vcsCloneRepo,
+ vcsSyncRepos
+ }
+ where
+ vcsCloneRepo :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepo
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
+ vcsCloneRepo verbosity prog repo srcurl destdir =
+ [ programInvocation prog cloneArgs ]
+ where
+ cloneArgs = [cloneCmd, srcurl, destdir] ++ tagArgs ++ verboseArg
+ -- At some point the @clone@ command was introduced as an alias for
+ -- @get@, and @clone@ seems to be the recommended one now.
+ cloneCmd | programVersion prog >= Just (mkVersion [2,8])
+ = "clone"
+ | otherwise = "get"
+ tagArgs = case repoTag repo of
+ Nothing -> []
+ Just tag -> ["-t", tag]
+ verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+
+ vcsSyncRepos :: Verbosity -> ConfiguredProgram
+ -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath]
+ vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs"
+
+darcsProgram :: Program
+darcsProgram = (simpleProgram "darcs") {
+ programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- "2.8.5 (release)"
+ (ver:_) -> ver
+ _ -> ""
+ }
+
+
+-- | VCS driver for Git.
+--
+vcsGit :: VCS Program
+vcsGit =
+ VCS {
+ vcsRepoType = Git,
+ vcsProgram = gitProgram,
+ vcsCloneRepo,
+ vcsSyncRepos
+ }
+ where
+ vcsCloneRepo :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepo
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
+ vcsCloneRepo verbosity prog repo srcurl destdir =
+ [ programInvocation prog cloneArgs ]
+ -- And if there's a tag, we have to do that in a second step:
+ ++ [ (programInvocation prog (checkoutArgs tag)) {
+ progInvokeCwd = Just destdir
+ }
+ | tag <- maybeToList (repoTag repo) ]
+ where
+ cloneArgs = ["clone", srcurl, destdir]
+ ++ branchArgs ++ verboseArg
+ branchArgs = case repoBranch repo of
+ Just b -> ["--branch", b]
+ Nothing -> []
+ checkoutArgs tag = ["checkout", tag] ++ verboseArg
+ verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+
+ vcsSyncRepos :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepo, FilePath)]
+ -> IO [MonitorFilePath]
+ vcsSyncRepos _ _ [] = return []
+ vcsSyncRepos verbosity gitProg
+ ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
+
+ vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing
+ sequence_
+ [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)
+ | (repo, localDir) <- secondaryRepos ]
+ return [ monitorDirectoryExistence dir
+ | dir <- (primaryLocalDir : map snd secondaryRepos) ]
+
+ vcsSyncRepo verbosity gitProg SourceRepo{..} localDir peer = do
+ exists <- doesDirectoryExist localDir
+ if exists
+ then git localDir ["fetch"]
+ else git (takeDirectory localDir) cloneArgs
+ git localDir checkoutArgs
+ where
+ git :: FilePath -> [String] -> IO ()
+ git cwd args = runProgramInvocation verbosity $
+ (programInvocation gitProg args) {
+ progInvokeCwd = Just cwd
+ }
+
+ cloneArgs = ["clone", "--no-checkout", loc, localDir]
+ ++ case peer of
+ Nothing -> []
+ Just peerLocalDir -> ["--reference", peerLocalDir]
+ ++ verboseArg
+ where Just loc = repoLocation
+ checkoutArgs = [ "checkout", "--detach", "--force"
+ , checkoutTarget ] ++ verboseArg
+ checkoutTarget = fromMaybe "HEAD" (repoBranch `mplus` repoTag)
+ verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+
+gitProgram :: Program
+gitProgram = (simpleProgram "git") {
+ programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- "git version 2.5.5"
+ (_:_:ver:_) -> ver
+ _ -> ""
+ }
+
+
+-- | VCS driver for Mercurial.
+--
+vcsHg :: VCS Program
+vcsHg =
+ VCS {
+ vcsRepoType = Mercurial,
+ vcsProgram = hgProgram,
+ vcsCloneRepo,
+ vcsSyncRepos
+ }
+ where
+ vcsCloneRepo :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepo
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
+ vcsCloneRepo verbosity prog repo srcurl destdir =
+ [ programInvocation prog cloneArgs ]
+ where
+ cloneArgs = ["clone", srcurl, destdir]
+ ++ branchArgs ++ tagArgs ++ verboseArg
+ branchArgs = case repoBranch repo of
+ Just b -> ["--branch", b]
+ Nothing -> []
+ tagArgs = case repoTag repo of
+ Just t -> ["--rev", t]
+ Nothing -> []
+ verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+
+ vcsSyncRepos :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepo, FilePath)]
+ -> IO [MonitorFilePath]
+ vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg"
+
+hgProgram :: Program
+hgProgram = (simpleProgram "hg") {
+ programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- Mercurial Distributed SCM (version 3.5.2)\n ... long message
+ (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver
+ _ -> ""
+ }
+
+
+-- | VCS driver for Subversion.
+--
+vcsSvn :: VCS Program
+vcsSvn =
+ VCS {
+ vcsRepoType = SVN,
+ vcsProgram = svnProgram,
+ vcsCloneRepo,
+ vcsSyncRepos
+ }
+ where
+ vcsCloneRepo :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepo
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
+ vcsCloneRepo verbosity prog _repo srcurl destdir =
+ [ programInvocation prog checkoutArgs ]
+ where
+ checkoutArgs = ["checkout", srcurl, destdir] ++ verboseArg
+ verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ --TODO: branch or tag?
+
+ vcsSyncRepos :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepo, FilePath)]
+ -> IO [MonitorFilePath]
+ vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"
+
+svnProgram :: Program
+svnProgram = (simpleProgram "svn") {
+ programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- svn, version 1.9.4 (r1740329)\n ... long message
+ (_:_:ver:_) -> ver
+ _ -> ""
+ }
+
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 7273d6ca0a..c9f9b9df60 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -234,6 +234,7 @@ library
Distribution.Client.Utils
Distribution.Client.Utils.Assertion
Distribution.Client.Utils.Json
+ Distribution.Client.VCS
Distribution.Client.Win32SelfUpgrade
Distribution.Client.World
Distribution.Solver.Compat.Prelude
@@ -489,6 +490,7 @@ executable cabal
Distribution.Client.Utils
Distribution.Client.Utils.Assertion
Distribution.Client.Utils.Json
+ Distribution.Client.VCS
Distribution.Client.Win32SelfUpgrade
Distribution.Client.World
Distribution.Solver.Compat.Prelude
@@ -572,6 +574,7 @@ executable cabal
UnitTests.Distribution.Client.ArbitraryInstances
UnitTests.Distribution.Client.FileMonitor
+ UnitTests.Distribution.Client.Get
UnitTests.Distribution.Client.GZipUtils
UnitTests.Distribution.Client.Glob
UnitTests.Distribution.Client.IndexUtils.Timestamp
@@ -584,6 +587,7 @@ executable cabal
UnitTests.Distribution.Client.Tar
UnitTests.Distribution.Client.Targets
UnitTests.Distribution.Client.UserConfig
+ UnitTests.Distribution.Client.VCS
UnitTests.Distribution.Solver.Modular.Builder
UnitTests.Distribution.Solver.Modular.DSL
UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
new file mode 100644
index 0000000000..f31fbb602c
--- /dev/null
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
@@ -0,0 +1,222 @@
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
+module UnitTests.Distribution.Client.Get (tests) where
+
+import Distribution.Client.Get
+
+import Distribution.Types.PackageId
+import Distribution.Types.PackageName
+import Distribution.Types.SourceRepo
+import Distribution.Verbosity as Verbosity
+import Distribution.Version
+import Distribution.Simple.Utils
+ ( withTempDirectory )
+
+import Control.Monad
+import Control.Exception
+import Data.Typeable
+import System.FilePath
+import System.Directory
+import System.Exit
+import System.IO.Error
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import UnitTests.Options (RunNetworkTests (..))
+
+tests :: [TestTree]
+tests =
+ [ testGroup "forkPackages"
+ [ testCase "no repos" testNoRepos
+ , testCase "no repos of requested kind" testNoReposOfKind
+ , testCase "no repo type specified" testNoRepoType
+ , testCase "unsupported repo type" testUnsupportedRepoType
+ , testCase "no repo location specified" testNoRepoLocation
+ , testCase "correct repo kind selection" testSelectRepoKind
+ , testCase "repo destination exists" testRepoDestinationExists
+ , testCase "git fetch failure" testGitFetchFailed
+ ]
+ , askOption $ \(RunNetworkTests doRunNetTests) ->
+ testGroup "forkPackages, network tests" $
+ includeTestsIf doRunNetTests $
+ [ testCase "git clone" testNetworkGitClone
+ ]
+ ]
+ where
+ includeTestsIf True xs = xs
+ includeTestsIf False _ = []
+
+
+
+verbosity :: Verbosity
+verbosity = Verbosity.silent -- verbose
+
+pkgidfoo :: PackageId
+pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1,0])
+
+
+-- ------------------------------------------------------------
+-- * Unit tests
+-- ------------------------------------------------------------
+
+testNoRepos :: Assertion
+testNoRepos = do
+ e <- assertException $ forkPackagesRepo verbosity "." Nothing pkgrepos
+ e @?= ForkExceptionNoSourceRepos pkgidfoo
+ where
+ pkgrepos = [(pkgidfoo, [])]
+
+
+testNoReposOfKind :: Assertion
+testNoReposOfKind = do
+ e <- assertException $ forkPackagesRepo verbosity "." repokind pkgrepos
+ e @?= ForkExceptionNoSourceReposOfKind pkgidfoo repokind
+ where
+ pkgrepos = [(pkgidfoo, [repo])]
+ repo = emptySourceRepo RepoHead
+ repokind = Just RepoThis
+
+
+testNoRepoType :: Assertion
+testNoRepoType = do
+ e <- assertException $ forkPackagesRepo verbosity "." Nothing pkgrepos
+ e @?= ForkExceptionNoRepoType pkgidfoo repo
+ where
+ pkgrepos = [(pkgidfoo, [repo])]
+ repo = emptySourceRepo RepoHead
+
+
+testUnsupportedRepoType :: Assertion
+testUnsupportedRepoType = do
+ e <- assertException $ forkPackagesRepo verbosity "." Nothing pkgrepos
+ e @?= ForkExceptionUnsupportedRepoType pkgidfoo repo repotype
+ where
+ pkgrepos = [(pkgidfoo, [repo])]
+ repo = (emptySourceRepo RepoHead) {
+ repoType = Just repotype
+ }
+ repotype = OtherRepoType "baz"
+
+
+testNoRepoLocation :: Assertion
+testNoRepoLocation = do
+ e <- assertException $ forkPackagesRepo verbosity "." Nothing pkgrepos
+ e @?= ForkExceptionNoRepoLocation pkgidfoo repo
+ where
+ pkgrepos = [(pkgidfoo, [repo])]
+ repo = (emptySourceRepo RepoHead) {
+ repoType = Just repotype
+ }
+ repotype = Darcs
+
+
+testSelectRepoKind :: Assertion
+testSelectRepoKind =
+ sequence_
+ [ do e <- test requestedRepoType pkgrepos
+ e @?= ForkExceptionNoRepoType pkgidfoo expectedRepo
+
+ e' <- test requestedRepoType (reverse pkgrepos)
+ e' @?= ForkExceptionNoRepoType pkgidfoo expectedRepo
+ | let test rt rs = assertException $ forkPackagesRepo verbosity "." rt rs
+ , (requestedRepoType, expectedRepo) <- cases
+ ]
+ where
+ pkgrepos = [(pkgidfoo, [repo1, repo2, repo3])]
+ repo1 = emptySourceRepo RepoThis
+ repo2 = emptySourceRepo RepoHead
+ repo3 = emptySourceRepo (RepoKindUnknown "bar")
+ cases = [ (Nothing, repo1)
+ , (Just RepoThis, repo1)
+ , (Just RepoHead, repo2)
+ , (Just (RepoKindUnknown "bar"), repo3)
+ ]
+
+
+testRepoDestinationExists :: Assertion
+testRepoDestinationExists =
+ withTempDirectory verbosity "." "repos" $ \tmpdir -> do
+ let pkgdir = tmpdir </> "foo"
+ createDirectory pkgdir
+ e1 <- assertException $ forkPackagesRepo verbosity tmpdir Nothing pkgrepos
+ e1 @?= ForkExceptionDestinationExists pkgidfoo pkgdir True {- isdir -}
+
+ removeDirectory pkgdir
+
+ writeFile pkgdir ""
+ e2 <- assertException $ forkPackagesRepo verbosity tmpdir Nothing pkgrepos
+ e2 @?= ForkExceptionDestinationExists pkgidfoo pkgdir False {- isfile -}
+ where
+ pkgrepos = [(pkgidfoo, [repo])]
+ repo = (emptySourceRepo RepoHead) {
+ repoType = Just Darcs,
+ repoLocation = Just ""
+ }
+
+
+testGitFetchFailed :: Assertion
+testGitFetchFailed =
+ withTempDirectory verbosity "." "repos" $ \tmpdir -> do
+ let srcdir = tmpdir </> "src"
+ repo = (emptySourceRepo RepoHead) {
+ repoType = Just Git,
+ repoLocation = Just srcdir
+ }
+ pkgrepos = [(pkgidfoo, [repo])]
+ e1 <- assertException $ forkPackagesRepo verbosity tmpdir Nothing pkgrepos
+ e1 @?= ForkExceptionFailedWithExitCode pkgidfoo repo "git" (ExitFailure 128)
+
+
+testNetworkGitClone :: Assertion
+testNetworkGitClone =
+ withTempDirectory verbosity "." "repos" $ \tmpdir -> do
+ let repo1 = (emptySourceRepo RepoHead) {
+ repoType = Just Git,
+ repoLocation = Just "https://github.com/haskell/zlib.git"
+ }
+ forkPackagesRepo verbosity tmpdir Nothing [(mkpkgid "zlib1", [repo1])]
+ assertFileContains (tmpdir </> "zlib1/zlib.cabal") ["name:", "zlib"]
+
+ let repo2 = (emptySourceRepo RepoHead) {
+ repoType = Just Git,
+ repoLocation = Just (tmpdir </> "zlib1")
+ }
+ forkPackagesRepo verbosity tmpdir Nothing [(mkpkgid "zlib2", [repo2])]
+ assertFileContains (tmpdir </> "zlib2/zlib.cabal") ["name:", "zlib"]
+
+ let repo3 = (emptySourceRepo RepoHead) {
+ repoType = Just Git,
+ repoLocation = Just (tmpdir </> "zlib1"),
+ repoTag = Just "0.5.0.0"
+ }
+ forkPackagesRepo verbosity tmpdir Nothing [(mkpkgid "zlib3", [repo3])]
+ assertFileContains (tmpdir </> "zlib3/zlib.cabal") ["version:", "0.5.0.0"]
+ where
+ mkpkgid nm = PackageIdentifier (mkPackageName nm) (mkVersion [])
+
+
+-- ------------------------------------------------------------
+-- * HUnit utils
+-- ------------------------------------------------------------
+
+assertException :: forall e a. (Exception e, HasCallStack) => IO a -> IO e
+assertException action = do
+ r <- try action
+ case r of
+ Left e -> return e
+ Right _ -> assertFailure $ "expected exception of type "
+ ++ show (typeOf (undefined :: e))
+
+
+-- | Expect that one line in a file matches exactly the given words (i.e. at
+-- least insensitive to whitespace)
+--
+assertFileContains :: HasCallStack => FilePath -> [String] -> Assertion
+assertFileContains file expected = do
+ c <- readFile file `catch` \e ->
+ if isDoesNotExistError e
+ then assertFailure $ "expected a file to exist: " ++ file
+ else throwIO e
+ unless (expected `elem` map words (lines c)) $
+ assertFailure $ "expected the file " ++ file ++ " to contain "
+ ++ show (take 100 expected)
+
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
new file mode 100644
index 0000000000..bc4b204af3
--- /dev/null
+++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
@@ -0,0 +1,691 @@
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
+module UnitTests.Distribution.Client.VCS {-(tests)-} where
+
+import Distribution.Client.VCS
+import Distribution.Simple.Program
+import Distribution.Simple.Utils
+ ( withTempDirectory )
+import Distribution.Verbosity as Verbosity
+import Distribution.Types.SourceRepo
+
+import Data.List
+import Data.Tuple
+import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Set as Set
+import Data.Set (Set)
+import Data.Char (isSpace)
+
+import Control.Monad
+import qualified Control.Monad.State as State
+import Control.Monad.State (StateT, liftIO, execStateT)
+import Control.Exception
+import Control.Concurrent (threadDelay)
+
+import System.IO
+import System.FilePath
+import System.Directory
+import System.Random
+
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import UnitTests.Distribution.Client.ArbitraryInstances
+
+
+-- | These tests take the following approach: we generate a pure representation
+-- of a repository plus a corresponding real repository, and then run various
+-- test operations and compare the actual working state with the expected
+-- working state.
+--
+-- The first test simply checks that the test infrastructure works. It
+-- constructs a repository on disk and then checks out every tag or commmit
+-- and checks that the working state is the same as the pure representation.
+--
+-- The second test works in a similar way but tests 'syncSourceRepos'. It
+-- uses an arbitrary source repo and a set of (initially empty) destination
+-- directories. It picks a number of tags or commits from the source repo and
+-- synchronises the destination directories to those target states, and then
+-- checks that the working state is as expected (given the pure representation).
+--
+tests :: MTimeChange -> [TestTree]
+tests _mtimeChange =
+ [ testGroup "check VCS test framework"
+ [ testProperty "git" prop_framework_git
+-- , testProperty "darcs" (prop_framework_darcs mtimeChange)
+ ]
+ , testGroup "cloneSourceRepo"
+ [ testProperty "git" prop_cloneRepo_git
+-- , testProperty "darcs" (prop_cloneRepo_darcs mtimeChange)
+ ]
+ , testGroup "syncSourceRepos"
+ [ testProperty "git" prop_syncRepos_git
+-- , testProperty "darcs" (prop_syncRepos_darcs mtimeChange)
+ ]
+ ]
+
+
+prop_framework_git :: BranchingRepoRecipe -> Property
+prop_framework_git =
+ ioProperty
+ . prop_framework vcsGit vcsTestDriverGit
+ . WithBranchingSupport
+
+prop_framework_darcs :: MTimeChange -> NonBranchingRepoRecipe -> Property
+prop_framework_darcs mtimeChange =
+ ioProperty
+ . prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange)
+ . WithoutBranchingSupport
+
+prop_cloneRepo_git :: BranchingRepoRecipe -> Property
+prop_cloneRepo_git =
+ ioProperty
+ . prop_cloneRepo vcsGit vcsTestDriverGit
+ . WithBranchingSupport
+
+prop_cloneRepo_darcs :: MTimeChange
+ -> NonBranchingRepoRecipe -> Property
+prop_cloneRepo_darcs mtimeChange =
+ ioProperty
+ . prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange)
+ . WithoutBranchingSupport
+
+prop_syncRepos_git :: RepoDirSet -> SyncTargetIterations -> PrngSeed
+ -> BranchingRepoRecipe -> Property
+prop_syncRepos_git destRepoDirs syncTargetSetIterations seed =
+ ioProperty
+ . prop_syncRepos vcsGit vcsTestDriverGit
+ destRepoDirs syncTargetSetIterations seed
+ . WithBranchingSupport
+
+prop_syncRepos_darcs :: MTimeChange
+ -> RepoDirSet -> SyncTargetIterations -> PrngSeed
+ -> NonBranchingRepoRecipe -> Property
+prop_syncRepos_darcs mtimeChange destRepoDirs syncTargetSetIterations seed =
+ ioProperty
+ . prop_syncRepos vcsDarcs (vcsTestDriverDarcs mtimeChange)
+ destRepoDirs syncTargetSetIterations seed
+ . WithoutBranchingSupport
+
+
+-- ------------------------------------------------------------
+-- * General test setup
+-- ------------------------------------------------------------
+
+testSetup :: VCS Program
+ -> (Verbosity -> VCS ConfiguredProgram
+ -> FilePath -> VCSTestDriver)
+ -> RepoRecipe
+ -> (VCSTestDriver -> FilePath -> RepoState -> IO a)
+ -> IO a
+testSetup vcs mkVCSTestDriver repoRecipe theTest = do
+ -- test setup
+ Just vcs' <- configureVCS verbosity vcs
+ withTestDir $ \tmpdir -> do
+ let srcRepoPath = tmpdir </> "src"
+ vcsDriver = mkVCSTestDriver verbosity vcs' srcRepoPath
+ repoState <- createRepo vcsDriver repoRecipe
+
+ -- actual test
+ theTest vcsDriver tmpdir repoState
+ where
+ verbosity = silent
+
+-- ------------------------------------------------------------
+-- * Test 1: VCS infrastructure
+-- ------------------------------------------------------------
+
+-- | This test simply checks that the test infrastructure works. It constructs
+-- a repository on disk and then checks out every tag or commit and checks that
+-- the working state is the same as the pure representation.
+--
+prop_framework :: VCS Program
+ -> (Verbosity -> VCS ConfiguredProgram
+ -> FilePath -> VCSTestDriver)
+ -> RepoRecipe
+ -> IO ()
+prop_framework vcs mkVCSTestDriver repoRecipe =
+ testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
+ mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))
+ where
+ -- Check for any given tag/commit in the 'RepoState' that the working state
+ -- matches the actual working state from the repository at that tag/commit.
+ checkAtTag VCSTestDriver {..} tmpdir (tagname, expectedState) =
+ case vcsCheckoutTag of
+ -- We handle two cases: inplace checkouts for VCSs that support it
+ -- (e.g. git) and separate dir otherwise (e.g. darcs)
+ Left checkoutInplace -> do
+ checkoutInplace tagname
+ checkExpectedWorkingState vcsIgnoreFiles vcsRepoRoot expectedState
+
+ Right checkoutCloneTo -> do
+ checkoutCloneTo tagname destRepoPath
+ checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState
+ removeDirectoryRecursive destRepoPath
+ where
+ destRepoPath = tmpdir </> "dest"
+
+
+-- ------------------------------------------------------------
+-- * Test 2: 'cloneSourceRepo'
+-- ------------------------------------------------------------
+
+prop_cloneRepo :: VCS Program
+ -> (Verbosity -> VCS ConfiguredProgram
+ -> FilePath -> VCSTestDriver)
+ -> RepoRecipe
+ -> IO ()
+prop_cloneRepo vcs mkVCSTestDriver repoRecipe =
+ testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
+ mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))
+ where
+ checkAtTag VCSTestDriver{..} tmpdir (tagname, expectedState) = do
+ cloneSourceRepo verbosity vcsVCS repo vcsRepoRoot destRepoPath
+ checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState
+ removeDirectoryRecursive destRepoPath
+ where
+ destRepoPath = tmpdir </> "dest"
+ repo = (emptySourceRepo RepoThis) {
+ repoType = Just (vcsRepoType vcsVCS),
+ repoLocation = Just vcsRepoRoot,
+ repoTag = Just tagname
+ }
+ verbosity = silent
+
+
+-- ------------------------------------------------------------
+-- * Test 3: 'syncSourceRepos'
+-- ------------------------------------------------------------
+
+newtype RepoDirSet = RepoDirSet Int deriving Show
+newtype SyncTargetIterations = SyncTargetIterations Int deriving Show
+newtype PrngSeed = PrngSeed Int deriving Show
+
+prop_syncRepos :: VCS Program
+ -> (Verbosity -> VCS ConfiguredProgram
+ -> FilePath -> VCSTestDriver)
+ -> RepoDirSet
+ -> SyncTargetIterations
+ -> PrngSeed
+ -> RepoRecipe
+ -> IO ()
+prop_syncRepos vcs mkVCSTestDriver
+ repoDirs syncTargetSetIterations seed repoRecipe =
+ testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
+ let srcRepoPath = vcsRepoRoot vcsDriver
+ destRepoPaths = map (tmpdir </>) (getRepoDirs repoDirs)
+ in checkSyncRepos verbosity vcsDriver repoState
+ srcRepoPath destRepoPaths
+ syncTargetSetIterations seed
+ where
+ verbosity = silent
+
+ getRepoDirs :: RepoDirSet -> [FilePath]
+ getRepoDirs (RepoDirSet n) =
+ [ "dest" ++ show i | i <- [1..n] ]
+
+
+-- | The purpose of this test is to check that irrespective of the local cached
+-- repo dir we can sync it to an arbitrary target state. So we do that by
+-- syncing each target dir to a sequence of target states without cleaning it
+-- in between.
+--
+-- One slight complication is that 'syncSourceRepos' takes a whole list of
+-- target dirs to sync in one go (to allow for sharing). So we must actually
+-- generate and sync to a sequence of list of target repo states.
+--
+-- So, given a source repo dir, the corresponding 'RepoState' and a number of
+-- target repo dirs, pick a sequence of (lists of) sync targets from the
+-- 'RepoState' and syncronise the target dirs with those targets, checking for
+-- each one that the actual working state matches the expected repo state.
+--
+checkSyncRepos
+ :: Verbosity
+ -> VCSTestDriver
+ -> RepoState
+ -> FilePath
+ -> [FilePath]
+ -> SyncTargetIterations
+ -> PrngSeed
+ -> IO ()
+checkSyncRepos verbosity VCSTestDriver { vcsVCS = vcs, vcsIgnoreFiles }
+ repoState srcRepoPath destRepoPath
+ (SyncTargetIterations syncTargetSetIterations) (PrngSeed seed) =
+ mapM_ checkSyncTargetSet syncTargetSets
+ where
+ checkSyncTargetSet :: [(SourceRepo, FilePath, RepoWorkingState)] -> IO ()
+ checkSyncTargetSet syncTargets = do
+ _ <- vcsSyncRepos vcs verbosity (vcsProgram vcs)
+ [ (repo, repoPath)
+ | (repo, repoPath, _) <- syncTargets ]
+ sequence_
+ [ checkExpectedWorkingState vcsIgnoreFiles repoPath workingState
+ | (_, repoPath, workingState) <- syncTargets ]
+
+ syncTargetSets = take syncTargetSetIterations
+ $ pickSyncTargetSets (vcsRepoType vcs) repoState
+ srcRepoPath destRepoPath
+ (mkStdGen seed)
+
+pickSyncTargetSets :: RepoType -> RepoState
+ -> FilePath -> [FilePath]
+ -> StdGen
+ -> [[(SourceRepo, FilePath, RepoWorkingState)]]
+pickSyncTargetSets repoType repoState srcRepoPath dstReposPath =
+ assert (Map.size (allTags repoState) > 0) $
+ unfoldr (Just . swap . pickSyncTargetSet)
+ where
+ pickSyncTargetSet :: Rand [(SourceRepo, FilePath, RepoWorkingState)]
+ pickSyncTargetSet = flip (mapAccumL (flip pickSyncTarget)) dstReposPath
+
+ pickSyncTarget :: FilePath -> Rand (SourceRepo, FilePath, RepoWorkingState)
+ pickSyncTarget destRepoPath prng =
+ (prng', (repo, destRepoPath, workingState))
+ where
+ repo = (emptySourceRepo RepoThis) {
+ repoType = Just repoType,
+ repoLocation = Just srcRepoPath,
+ repoTag = Just tag
+ }
+ (tag, workingState) = Map.elemAt tagIdx (allTags repoState)
+ (tagIdx, prng') = randomR (0, Map.size (allTags repoState) - 1) prng
+
+type Rand a = StdGen -> (StdGen, a)
+
+instance Arbitrary RepoDirSet where
+ arbitrary =
+ sized $ \n -> oneof $ [ RepoDirSet <$> pure 1 ]
+ ++ [ RepoDirSet <$> choose (2,5) | n >= 3 ]
+ shrink (RepoDirSet n) =
+ [ RepoDirSet i | i <- shrink n, i > 0 ]
+
+instance Arbitrary SyncTargetIterations where
+ arbitrary =
+ sized $ \n -> SyncTargetIterations <$> elements [ 1 .. min 20 (n + 1) ]
+ shrink (SyncTargetIterations n) =
+ [ SyncTargetIterations i | i <- shrink n, i > 0 ]
+
+instance Arbitrary PrngSeed where
+ arbitrary = PrngSeed <$> arbitraryBoundedRandom
+
+
+-- ------------------------------------------------------------
+-- * Instructions for constructing repositories
+-- ------------------------------------------------------------
+
+-- These instructions for constructing a repository can be interpreted in two
+-- ways: to make a pure representation of repository state, and to execute
+-- VCS commands to make a repository on-disk.
+
+data FileUpdate = FileUpdate FilePath String deriving Show
+data Commit = Commit [FileUpdate] deriving Show
+data TaggedCommits = TaggedCommits TagName [Commit] deriving Show
+data BranchCommits = BranchCommits BranchName [Commit] deriving Show
+
+type BranchName = String
+type TagName = String
+
+-- | Instructions to make a repository without branches, for VCSs that do not
+-- support branches (e.g. darcs).
+newtype NonBranchingRepoRecipe = NonBranchingRepoRecipe [TaggedCommits]
+ deriving Show
+
+-- | Instructions to make a repository with branches, for VCSs that do
+-- support branches (e.g. git).
+newtype BranchingRepoRecipe = BranchingRepoRecipe
+ [Either TaggedCommits BranchCommits]
+ deriving Show
+
+data RepoRecipe = WithBranchingSupport BranchingRepoRecipe
+ | WithoutBranchingSupport NonBranchingRepoRecipe
+
+-- ---------------------------------------------------------------------------
+-- Arbitrary instances for them
+
+instance Arbitrary FileUpdate where
+ arbitrary = FileUpdate <$> genFileName <*> genFileContent
+ where
+ genFileName = (\c -> "file/" ++ [c]) <$> choose ('A', 'E')
+ genFileContent = vectorOf 10 (choose ('#', '~'))
+
+instance Arbitrary Commit where
+ arbitrary = Commit <$> shortListOf1 5 arbitrary
+ shrink (Commit writes) = Commit <$> filter (not . null) (shrink writes)
+
+instance Arbitrary TaggedCommits where
+ arbitrary = TaggedCommits <$> genTagName <*> shortListOf1 5 arbitrary
+ where
+ genTagName = ("tag_" ++) <$> shortListOf1 5 (choose ('A', 'Z'))
+ shrink (TaggedCommits tag commits) =
+ TaggedCommits tag <$> filter (not . null) (shrink commits)
+
+instance Arbitrary BranchCommits where
+ arbitrary = BranchCommits <$> genBranchName <*> shortListOf1 5 arbitrary
+ where
+ genBranchName =
+ sized $ \n ->
+ (\c -> "branch_" ++ [c]) <$> elements (take (max 1 n) ['A'..'E'])
+
+ shrink (BranchCommits branch commits) =
+ BranchCommits branch <$> filter (not . null) (shrink commits)
+
+instance Arbitrary NonBranchingRepoRecipe where
+ arbitrary = NonBranchingRepoRecipe <$> shortListOf1 15 arbitrary
+ shrink (NonBranchingRepoRecipe xs) =
+ NonBranchingRepoRecipe <$> filter (not . null) (shrink xs)
+
+instance Arbitrary BranchingRepoRecipe where
+ arbitrary = BranchingRepoRecipe <$> shortListOf1 15 taggedOrBranch
+ where
+ taggedOrBranch = frequency [ (3, Left <$> arbitrary)
+ , (1, Right <$> arbitrary)
+ ]
+ shrink (BranchingRepoRecipe xs) =
+ BranchingRepoRecipe <$> filter (not . null) (shrink xs)
+
+
+-- ------------------------------------------------------------
+-- * A pure model of repository state
+-- ------------------------------------------------------------
+
+-- | The full state of a repository. In particular it records the full working
+-- state for every tag.
+--
+-- This is also the interpreter state for executing a 'RepoRecipe'.
+--
+-- This allows us to compare expected working states with the actual files in
+-- the working directory of a repository. See 'checkExpectedWorkingState'.
+--
+data RepoState =
+ RepoState {
+ currentBranch :: BranchName,
+ currentWorking :: RepoWorkingState,
+ allTags :: Map TagOrCommitId RepoWorkingState,
+ allBranches :: Map BranchName RepoWorkingState
+ }
+ deriving Show
+
+type RepoWorkingState = Map FilePath String
+type CommitId = String
+type TagOrCommitId = String
+
+
+------------------------------------------------------------------------------
+-- Functions used to interpret instructions for constructing repositories
+
+initialRepoState :: RepoState
+initialRepoState =
+ RepoState {
+ currentBranch = "branch_master",
+ currentWorking = Map.empty,
+ allTags = Map.empty,
+ allBranches = Map.empty
+ }
+
+updateFile :: FilePath -> String -> RepoState -> RepoState
+updateFile filename content state@RepoState{currentWorking} =
+ state { currentWorking = Map.insert filename content currentWorking }
+
+addTagOrCommit :: TagOrCommitId -> RepoState -> RepoState
+addTagOrCommit commit state@RepoState{currentWorking, allTags} =
+ state { allTags = Map.insert commit currentWorking allTags }
+
+switchBranch :: BranchName -> RepoState -> RepoState
+switchBranch branch state@RepoState{currentWorking, currentBranch, allBranches} =
+ -- Use updated allBranches to cover case of switching to the same branch
+ let allBranches' = Map.insert currentBranch currentWorking allBranches in
+ state {
+ currentBranch = branch,
+ currentWorking = case Map.lookup branch allBranches' of
+ Just working -> working
+ -- otherwise we're creating a new branch, which starts
+ -- from our current branch state
+ Nothing -> currentWorking,
+ allBranches = allBranches'
+ }
+
+
+-- ------------------------------------------------------------
+-- * Comparing on-disk with expected 'RepoWorkingState'
+-- ------------------------------------------------------------
+
+-- | Compare expected working states with the actual files in
+-- the working directory of a repository.
+--
+checkExpectedWorkingState :: Set FilePath
+ -> FilePath -> RepoWorkingState -> IO ()
+checkExpectedWorkingState ignore repoPath expectedState = do
+ currentState <- getCurrentWorkingState ignore repoPath
+ unless (currentState == expectedState) $
+ throwIO (WorkingStateMismatch expectedState currentState)
+
+data WorkingStateMismatch =
+ WorkingStateMismatch RepoWorkingState -- expected
+ RepoWorkingState -- actual
+ deriving Show
+
+instance Exception WorkingStateMismatch
+
+getCurrentWorkingState :: Set FilePath -> FilePath -> IO RepoWorkingState
+getCurrentWorkingState ignore repoRoot = do
+ entries <- getDirectoryContentsRecursive ignore repoRoot ""
+ Map.fromList <$> mapM getFileEntry
+ [ file | (file, isDir) <- entries, not isDir ]
+ where
+ getFileEntry name =
+ withBinaryFile (repoRoot </> name) ReadMode $ \h -> do
+ str <- hGetContents h
+ _ <- evaluate (length str)
+ return (name, str)
+
+getDirectoryContentsRecursive :: Set FilePath -> FilePath -> FilePath
+ -> IO [(FilePath, Bool)]
+getDirectoryContentsRecursive ignore dir0 dir = do
+ entries <- getDirectoryContents (dir0 </> dir)
+ entries' <- sequence
+ [ do isdir <- doesDirectoryExist (dir0 </> dir </> entry)
+ return (dir </> entry, isdir)
+ | entry <- entries
+ , not (isPrefixOf "." entry)
+ , (dir </> entry) `Set.notMember` ignore
+ ]
+ let subdirs = [ d | (d, True) <- entries' ]
+ subdirEntries <- mapM (getDirectoryContentsRecursive ignore dir0) subdirs
+ return (concat (entries' : subdirEntries))
+
+
+-- ------------------------------------------------------------
+-- * Executing instructions to make on-disk VCS repos
+-- ------------------------------------------------------------
+
+-- | Execute the instructions in a 'RepoRecipe' using the given 'VCSTestDriver'
+-- to make an on-disk repository.
+--
+-- This also returns a 'RepoState'. This is done as part of construction to
+-- support VCSs like git that have commit ids, so that those commit ids can be
+-- included in the 'RepoState's 'allTags' set.
+--
+createRepo :: VCSTestDriver -> RepoRecipe -> IO RepoState
+createRepo vcsDriver@VCSTestDriver{vcsRepoRoot, vcsInit} recipe = do
+ createDirectory vcsRepoRoot
+ createDirectory (vcsRepoRoot </> "file")
+ vcsInit
+ execStateT createRepoAction initialRepoState
+ where
+ createRepoAction :: StateT RepoState IO ()
+ createRepoAction = case recipe of
+ WithoutBranchingSupport r -> execNonBranchingRepoRecipe vcsDriver r
+ WithBranchingSupport r -> execBranchingRepoRecipe vcsDriver r
+
+type CreateRepoAction a = VCSTestDriver -> a -> StateT RepoState IO ()
+
+execNonBranchingRepoRecipe :: CreateRepoAction NonBranchingRepoRecipe
+execNonBranchingRepoRecipe vcsDriver (NonBranchingRepoRecipe taggedCommits) =
+ mapM_ (execTaggdCommits vcsDriver) taggedCommits
+
+execBranchingRepoRecipe :: CreateRepoAction BranchingRepoRecipe
+execBranchingRepoRecipe vcsDriver (BranchingRepoRecipe taggedCommits) =
+ mapM_ (either (execTaggdCommits vcsDriver)
+ (execBranchCommits vcsDriver))
+ taggedCommits
+
+execBranchCommits :: CreateRepoAction BranchCommits
+execBranchCommits vcsDriver@VCSTestDriver{vcsSwitchBranch}
+ (BranchCommits branch commits) = do
+ mapM_ (execCommit vcsDriver) commits
+ -- add commits and then switch branch
+ State.modify (switchBranch branch)
+ state <- State.get -- repo state after the commits and branch switch
+ liftIO $ vcsSwitchBranch state branch
+
+ -- It may seem odd that we add commits on the existing branch and then
+ -- switch branch. In part this is because git cannot branch from an empty
+ -- repo state, it complains that the master branch doesn't exist yet.
+
+execTaggdCommits :: CreateRepoAction TaggedCommits
+execTaggdCommits vcsDriver@VCSTestDriver{vcsTagState}
+ (TaggedCommits tagname commits) = do
+ mapM_ (execCommit vcsDriver) commits
+ -- add commits then tag
+ state <- State.get -- repo state after the commits
+ liftIO $ vcsTagState state tagname
+ State.modify (addTagOrCommit tagname)
+
+execCommit :: CreateRepoAction Commit
+execCommit vcsDriver@VCSTestDriver{..} (Commit fileUpdates) = do
+ mapM_ (execFileUpdate vcsDriver) fileUpdates
+ state <- State.get -- existing state, not updated
+ mcommit <- liftIO $ vcsCommitChanges state
+ State.modify (maybe id addTagOrCommit mcommit)
+
+execFileUpdate :: CreateRepoAction FileUpdate
+execFileUpdate VCSTestDriver{..} (FileUpdate filename content) = do
+ liftIO $ writeFile (vcsRepoRoot </> filename) content
+ state <- State.get -- existing state, not updated
+ liftIO $ vcsAddFile state filename
+ State.modify (updateFile filename content)
+
+
+-- ------------------------------------------------------------
+-- * VCSTestDriver for various VCSs
+-- ------------------------------------------------------------
+
+-- | Extends 'VCS' with extra methods to construct a repository. Used by
+-- 'createRepo'.
+--
+-- Several of the methods are allowed to rely on the current 'RepoState'
+-- because some VCSs need different commands for initial vs later actions
+-- (like adding a file to the tracked set, or creating a new branch).
+--
+-- The driver instance knows the particular repo directory.
+--
+data VCSTestDriver = VCSTestDriver {
+ vcsVCS :: VCS ConfiguredProgram,
+ vcsRepoRoot :: FilePath,
+ vcsIgnoreFiles :: Set FilePath,
+ vcsInit :: IO (),
+ vcsAddFile :: RepoState -> FilePath -> IO (),
+ vcsCommitChanges :: RepoState -> IO (Maybe CommitId),
+ vcsTagState :: RepoState -> TagName -> IO (),
+ vcsSwitchBranch :: RepoState -> BranchName -> IO (),
+ vcsCheckoutTag :: Either (TagName -> IO ())
+ (TagName -> FilePath -> IO ())
+ }
+
+
+vcsTestDriverGit :: Verbosity -> VCS ConfiguredProgram
+ -> FilePath -> VCSTestDriver
+vcsTestDriverGit verbosity vcs repoRoot =
+ VCSTestDriver {
+ vcsVCS = vcs
+
+ , vcsRepoRoot = repoRoot
+
+ , vcsIgnoreFiles = Set.empty
+
+ , vcsInit =
+ git $ ["init"] ++ verboseArg
+
+ , vcsAddFile = \_ filename ->
+ git ["add", filename]
+
+ , vcsCommitChanges = \_state -> do
+ git $ ["commit", "--all", "--message=a patch",
+ "--author=Author <author@example.com>"] ++ verboseArg
+ commit <- git' ["log", "--format=%H", "-1"]
+ let commit' = takeWhile (not . isSpace) commit
+ return (Just commit')
+
+ , vcsTagState = \_ tagname ->
+ git ["tag", "--force", tagname]
+
+ , vcsSwitchBranch = \RepoState{allBranches} branchname -> do
+ unless (branchname `Map.member` allBranches) $
+ git ["branch", branchname]
+ git $ ["checkout", branchname] ++ verboseArg
+
+ , vcsCheckoutTag = Left $ \tagname ->
+ git $ ["checkout", "--detach", "--force", tagname] ++ verboseArg
+ }
+ where
+ gitInvocation args = (programInvocation (vcsProgram vcs) args) {
+ progInvokeCwd = Just repoRoot
+ }
+ git = runProgramInvocation verbosity . gitInvocation
+ git' = getProgramInvocationOutput verbosity . gitInvocation
+ verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+
+
+type MTimeChange = Int
+
+vcsTestDriverDarcs :: MTimeChange -> Verbosity -> VCS ConfiguredProgram
+ -> FilePath -> VCSTestDriver
+vcsTestDriverDarcs mtimeChange verbosity vcs repoRoot =
+ VCSTestDriver {
+ vcsVCS = vcs
+
+ , vcsRepoRoot = repoRoot
+
+ , vcsIgnoreFiles = Set.singleton "_darcs"
+
+ , vcsInit =
+ darcs ["initialize"]
+
+ , vcsAddFile = \state filename -> do
+ threadDelay mtimeChange
+ unless (filename `Map.member` currentWorking state) $
+ darcs ["add", filename]
+ -- Darcs's file change tracking relies on mtime changes,
+ -- so we have to be careful with doing stuff too quickly:
+
+ , vcsCommitChanges = \_state -> do
+ threadDelay mtimeChange
+ darcs ["record", "--all", "--author=author", "--name=a patch"]
+ return Nothing
+
+ , vcsTagState = \_ tagname ->
+ darcs ["tag", "--author=author", tagname]
+
+ , vcsSwitchBranch = \_ _ ->
+ fail "vcsSwitchBranch: darcs does not support branches within a repo"
+
+ , vcsCheckoutTag = Right $ \tagname dest ->
+ darcs ["clone", "--lazy", "--tag=^" ++ tagname ++ "$", ".", dest]
+ }
+ where
+ darcsInvocation args = (programInvocation (vcsProgram vcs) args) {
+ progInvokeCwd = Just repoRoot
+ }
+ darcs = runProgramInvocation verbosity . darcsInvocation
+
+
+-- ------------------------------------------------------------
+-- * Utils
+-- ------------------------------------------------------------
+
+withTestDir :: (FilePath -> IO a) -> IO a
+withTestDir action = do
+ systmpdir <- getTemporaryDirectory
+ withTempDirectory verbosity systmpdir "vcstest" action
+ where
+ verbosity = silent
+
diff --git a/cabal-install/tests/UnitTests/Options.hs b/cabal-install/tests/UnitTests/Options.hs
index 58510d3746..1edce03554 100644
--- a/cabal-install/tests/UnitTests/Options.hs
+++ b/cabal-install/tests/UnitTests/Options.hs
@@ -2,6 +2,7 @@
module UnitTests.Options ( OptionShowSolverLog(..)
, OptionMtimeChangeDelay(..)
+ , RunNetworkTests(..)
, extraOptions )
where
@@ -18,6 +19,7 @@ extraOptions :: [OptionDescription]
extraOptions =
[ Option (Proxy :: Proxy OptionShowSolverLog)
, Option (Proxy :: Proxy OptionMtimeChangeDelay)
+ , Option (Proxy :: Proxy RunNetworkTests)
]
newtype OptionShowSolverLog = OptionShowSolverLog Bool
@@ -25,7 +27,7 @@ newtype OptionShowSolverLog = OptionShowSolverLog Bool
instance IsOption OptionShowSolverLog where
defaultValue = OptionShowSolverLog False
- parseValue = fmap OptionShowSolverLog . safeRead
+ parseValue = fmap OptionShowSolverLog . safeReadBool
optionName = return "show-solver-log"
optionHelp = return "Show full log from the solver"
optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)
@@ -39,3 +41,12 @@ instance IsOption OptionMtimeChangeDelay where
optionName = return "mtime-change-delay"
optionHelp = return $ "How long to wait before attempting to detect"
++ "file modification, in microseconds"
+
+newtype RunNetworkTests = RunNetworkTests Bool
+ deriving Typeable
+
+instance IsOption RunNetworkTests where
+ defaultValue = RunNetworkTests True
+ parseValue = fmap RunNetworkTests . safeReadBool
+ optionName = return "run-network-tests"
+ optionHelp = return "Run tests that need network access (default true)."
--
GitLab