Sync repo — Darcs: Check whether we are already at the tag before re-…

…cloning repo.
haskell · Oct 29, 2020 · 496348c · 496348c
1 parent f9d1aa8
commit 496348c
Showing 1 changed file with 22 additions and 8 deletions.
diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-}
 module Distribution.Client.VCS (
     -- * VCS driver type
@@ -46,17 +47,18 @@ 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.Exception
-         ( throw )
+         ( 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 )
@@ -322,14 +324,26 @@ vcsDarcs =
           [ vcsSyncRepo verbosity prog repo localDir (Just primaryLocalDir)
           | (repo, localDir) <- secondaryRepos ]
 
-    vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer = do
-      removeDirectoryRecursive localDir `catch` \ case
-          e | isDoesNotExistError e -> pure ()
-            | otherwise -> throw e
-      darcs (takeDirectory localDir) cloneArgs
+    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 (_ :: SomeException) -> pure ()
+        _ -> do
+          removeDirectoryRecursive localDir `catch` \ case
+              e | isDoesNotExistError e -> pure ()
+                | otherwise -> throw e
+          darcs (takeDirectory localDir) cloneArgs
       where
         darcs :: FilePath -> [String] -> IO ()
-        darcs cwd args = runProgramInvocation verbosity (programInvocation prog args)
+        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