diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs
index c8f1f6c8b88bf615545cc67b255ef7cb2be4c4fd..e94e304be58b1683a97a1d3bd6b7e287c8e17967 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 0000000000000000000000000000000000000000..4a3fb1dcb6ba815f521c7b619bf1fe91ea0d797b
--- /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 7273d6ca0abba5cac59e36e22c305b44648411a3..c9f9b9df60f98f1001f9e197b40ca141c3857b67 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 0000000000000000000000000000000000000000..f31fbb602c816e3468fe99ae70383106a92227c7
--- /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 0000000000000000000000000000000000000000..bc4b204af3fd82fe3fb2a0ad15258e908a970ce8
--- /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 58510d3746340fb4a14386118df5800696689790..1edce0355426a1ade192b42466eabcfcc5bbb5d2 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)."