diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 2f2fd9fa41c..0b79c965876 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} module Distribution.Client.VCS ( -- * VCS driver type @@ -45,20 +47,29 @@ import Distribution.Simple.Program ( Program(programFindVersion) , ConfiguredProgram(programVersion) , simpleProgram, findProgramVersion - , ProgramInvocation(..), programInvocation, runProgramInvocation + , ProgramInvocation(..), programInvocation, runProgramInvocation, getProgramInvocationOutput , emptyProgramDb, requireProgram ) import Distribution.Version ( mkVersion ) import qualified Distribution.PackageDescription as PD +import Control.Applicative + ( liftA2 ) +import Control.Exception + ( throw, try ) import Control.Monad.Trans ( liftIO ) import qualified Data.Char as Char +import qualified Data.List as List import qualified Data.Map as Map import System.FilePath ( takeDirectory ) import System.Directory - ( doesDirectoryExist ) + ( doesDirectoryExist + , removeDirectoryRecursive + ) +import System.IO.Error + ( isDoesNotExistError ) -- | A driver for a version control system, e.g. git, darcs etc. @@ -306,7 +317,41 @@ vcsDarcs = vcsSyncRepos :: Verbosity -> ConfiguredProgram -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs" + vcsSyncRepos _ _ [] = return [] + vcsSyncRepos verbosity prog ((primaryRepo, primaryLocalDir) : secondaryRepos) = + monitors <$ do + vcsSyncRepo verbosity prog primaryRepo primaryLocalDir Nothing + for_ secondaryRepos $ \ (repo, localDir) -> + vcsSyncRepo verbosity prog repo localDir $ Just primaryLocalDir + where + dirs = primaryLocalDir : (snd <$> secondaryRepos) + monitors = monitorDirectoryExistence <$> dirs + + vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer = + try (lines <$> darcsWithOutput localDir ["log", "--last", "1"]) >>= \ case + Right (_:_:_:x:_) + | Just tag <- (List.stripPrefix "tagged " . List.dropWhile Char.isSpace) x + , Just tag' <- srpTag + , tag == tag' -> pure () + Left e | not (isDoesNotExistError e) -> throw e + _ -> do + removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw + darcs (takeDirectory localDir) cloneArgs + where + darcs :: FilePath -> [String] -> IO () + darcs = darcs' runProgramInvocation + + darcsWithOutput :: FilePath -> [String] -> IO String + darcsWithOutput = darcs' getProgramInvocationOutput + + darcs' f cwd args = f verbosity (programInvocation prog args) + { progInvokeCwd = Just cwd } + + cloneArgs = ["clone"] ++ tagArgs ++ [srpLocation, localDir] ++ verboseArg + tagArgs = case srpTag of + Nothing -> [] + Just tag -> ["-t" ++ tag] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] darcsProgram :: Program darcsProgram = (simpleProgram "darcs") { diff --git a/changelog.d/sync-repo-darcs b/changelog.d/sync-repo-darcs new file mode 100644 index 00000000000..3bbd63c2c18 --- /dev/null +++ b/changelog.d/sync-repo-darcs @@ -0,0 +1,2 @@ +synopsis: Sync repo darcs +prs: #7137