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

…cloning repo.
haskell · May 9, 2021 · 02e0dcb · 02e0dcb
1 parent 1fe4655
commit 02e0dcb
Showing 1 changed file with 21 additions and 6 deletions.
diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 module Distribution.Client.VCS (
     -- * VCS driver type
     VCS,
@@ -46,7 +49,7 @@ import Distribution.Simple.Program
          ( Program(programFindVersion)
          , ConfiguredProgram(programVersion)
          , simpleProgram, findProgramVersion
-         , ProgramInvocation(..), programInvocation, runProgramInvocation
+         , ProgramInvocation(..), programInvocation, runProgramInvocation, getProgramInvocationOutput
          , emptyProgramDb, requireProgram )
 import Distribution.Version
          ( mkVersion )
@@ -55,10 +58,11 @@ import qualified Distribution.PackageDescription as PD
 import Control.Applicative
          ( liftA2 )
 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 )
@@ -324,12 +328,23 @@ vcsDarcs =
         dirs = primaryLocalDir : (snd <$> secondaryRepos)
         monitors = monitorDirectoryExistence <$> dirs
 
-    vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer = do
-      removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw
-      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 ()
+        (_ :: Either SomeException _) -> do
+          removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw
+          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