Merge pull request #7137 from strake/sync-repo-darcs

Sync repo darcs
haskell · Aug 26, 2021 · 8f5b2f0 · 8f5b2f0
2 parents ea830d7 + 47ae4f4
commit 8f5b2f0
Show file tree

Hide file tree

Showing 2 changed files with 50 additions and 3 deletions.
diff --git 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
@@ -0,0 +1,2 @@
+synopsis: Sync repo darcs
+prs: #7137