cabal-install/src/Distribution/Client/VCS.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE LambdaCase #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE RankNTypes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7
   8 module Distribution.Client.VCS
   9   ( -- * VCS driver type
  10     VCS
  11   , vcsRepoType
  12   , vcsProgram
  13
  14     -- ** Type re-exports
  15   , RepoType
  16   , Program
  17   , ConfiguredProgram
  18
  19     -- * Validating 'SourceRepo's and configuring VCS drivers
  20   , validatePDSourceRepo
  21   , validateSourceRepo
  22   , validateSourceRepos
  23   , SourceRepoProblem (..)
  24   , configureVCS
  25   , configureVCSs
  26
  27     -- * Running the VCS driver
  28   , cloneSourceRepo
  29   , syncSourceRepos
  30
  31     -- * The individual VCS drivers
  32   , knownVCSs
  33   , vcsBzr
  34   , vcsDarcs
  35   , vcsGit
  36   , vcsHg
  37   , vcsSvn
  38   , vcsPijul
  39   ) where
  40
  41 import Distribution.Client.Compat.Prelude
  42 import Prelude ()
  43
  44 import Distribution.Client.RebuildMonad
  45   ( MonitorFilePath
  46   , Rebuild
  47   , monitorDirectoryExistence
  48   , monitorFiles
  49   )
  50 import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)
  51 import qualified Distribution.PackageDescription as PD
  52 import Distribution.Simple.Program
  53   ( ConfiguredProgram (programVersion)
  54   , Program (programFindVersion)
  55   , ProgramInvocation (..)
  56   , emptyProgramDb
  57   , findProgramVersion
  58   , getProgramInvocationOutput
  59   , programInvocation
  60   , requireProgram
  61   , runProgramInvocation
  62   , simpleProgram
  63   )
  64 import Distribution.Simple.Program.Db
  65   ( prependProgramSearchPath
  66   )
  67 import Distribution.System
  68   ( OS (Windows)
  69   , buildOS
  70   )
  71 import Distribution.Types.SourceRepo
  72   ( KnownRepoType (..)
  73   , RepoType (..)
  74   )
  75 import Distribution.Verbosity as Verbosity
  76   ( normal
  77   )
  78 import Distribution.Version
  79   ( mkVersion
  80   )
  81
  82 #if !MIN_VERSION_base(4,18,0)
  83 import Control.Applicative
  84          ( liftA2 )
  85 #endif
  86
  87 import Control.Exception
  88   ( throw
  89   , try
  90   )
  91 import Control.Monad.Trans
  92   ( liftIO
  93   )
  94 import qualified Data.Char as Char
  95 import qualified Data.List as List
  96 import qualified Data.Map as Map
  97 import System.Directory
  98   ( doesDirectoryExist
  99   , removeDirectoryRecursive
 100   , removePathForcibly
 101   )
 102 import System.FilePath
 103   ( takeDirectory
 104   , (</>)
 105   )
 106 import System.IO.Error
 107   ( isDoesNotExistError
 108   , isPermissionError
 109   )
 110 import qualified System.Process as Process
 111
 112 -- | A driver for a version control system, e.g. git, darcs etc.
 113 data VCS program = VCS
 114   { vcsRepoType :: RepoType
 115   -- ^ The type of repository this driver is for.
 116   , vcsProgram :: program
 117   -- ^ The vcs program itself.
 118   -- This is used at type 'Program' and 'ConfiguredProgram'.
 119   , vcsCloneRepo
 120       :: forall f
 121        . Verbosity
 122       -> ConfiguredProgram
 123       -> SourceRepositoryPackage f
 124       -> FilePath -- Source URI
 125       -> FilePath -- Destination directory
 126       -> [ProgramInvocation]
 127   -- ^ The program invocation(s) to get\/clone a repository into a fresh
 128   -- local directory.
 129   , vcsSyncRepos
 130       :: forall f
 131        . Verbosity
 132       -> ConfiguredProgram
 133       -> [(SourceRepositoryPackage f, FilePath)]
 134       -> IO [MonitorFilePath]
 135   -- ^ The program invocation(s) to synchronise a whole set of /related/
 136   -- repositories with corresponding local directories. Also returns the
 137   -- files that the command depends on, for change monitoring.
 138   }
 139
 140 -- ------------------------------------------------------------
 141
 142 -- * Selecting repos and drivers
 143
 144 -- ------------------------------------------------------------
 145
 146 data SourceRepoProblem
 147   = SourceRepoRepoTypeUnspecified
 148   | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType
 149   | SourceRepoLocationUnspecified
 150   deriving (Show)
 151
 152 -- | Validates that the 'SourceRepo' specifies a location URI and a repository
 153 -- type that is supported by a VCS driver.
 154 --
 155 -- | It also returns the 'VCS' driver we should use to work with it.
 156 validateSourceRepo
 157   :: SourceRepositoryPackage f
 158   -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program)
 159 validateSourceRepo = \repo -> do
 160   let rtype = srpType repo
 161   vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype
 162   let uri = srpLocation repo
 163   return (repo, uri, rtype, vcs)
 164   where
 165     a ?! e = maybe (Left e) Right a
 166
 167 validatePDSourceRepo
 168   :: PD.SourceRepo
 169   -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)
 170 validatePDSourceRepo repo = do
 171   rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified
 172   uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified
 173   validateSourceRepo
 174     SourceRepositoryPackage
 175       { srpType = rtype
 176       , srpLocation = uri
 177       , srpTag = PD.repoTag repo
 178       , srpBranch = PD.repoBranch repo
 179       , srpSubdir = PD.repoSubdir repo
 180       , srpCommand = mempty
 181       }
 182   where
 183     a ?! e = maybe (Left e) Right a
 184
 185 -- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return
 186 -- things in a convenient form to pass to 'configureVCSs', or to report
 187 -- problems.
 188 validateSourceRepos
 189   :: [SourceRepositoryPackage f]
 190   -> Either
 191       [(SourceRepositoryPackage f, SourceRepoProblem)]
 192       [(SourceRepositoryPackage f, String, RepoType, VCS Program)]
 193 validateSourceRepos rs =
 194   case partitionEithers (map validateSourceRepo' rs) of
 195     (problems@(_ : _), _) -> Left problems
 196     ([], vcss) -> Right vcss
 197   where
 198     validateSourceRepo'
 199       :: SourceRepositoryPackage f
 200       -> Either
 201           (SourceRepositoryPackage f, SourceRepoProblem)
 202           (SourceRepositoryPackage f, String, RepoType, VCS Program)
 203     validateSourceRepo' r =
 204       either
 205         (Left . (,) r)
 206         Right
 207         (validateSourceRepo r)
 208
 209 configureVCS
 210   :: Verbosity
 211   -> [FilePath]
 212   -- ^ Extra prog paths
 213   -> VCS Program
 214   -> IO (VCS ConfiguredProgram)
 215 configureVCS verbosity progPaths vcs@VCS{vcsProgram = prog} = do
 216   progPath <- prependProgramSearchPath verbosity progPaths [] emptyProgramDb
 217   asVcsConfigured <$> requireProgram verbosity prog progPath
 218   where
 219     asVcsConfigured (prog', _) = vcs{vcsProgram = prog'}
 220
 221 configureVCSs
 222   :: Verbosity
 223   -> [FilePath]
 224   -- ^ Extra prog paths
 225   -> Map RepoType (VCS Program)
 226   -> IO (Map RepoType (VCS ConfiguredProgram))
 227 configureVCSs verbosity progPaths = traverse (configureVCS verbosity progPaths)
 228
 229 -- ------------------------------------------------------------
 230
 231 -- * Running the driver
 232
 233 -- ------------------------------------------------------------
 234
 235 -- | Clone a single source repo into a fresh directory, using a configured VCS.
 236 --
 237 -- This is for making a new copy, not synchronising an existing copy. It will
 238 -- fail if the destination directory already exists.
 239 --
 240 -- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first.
 241 cloneSourceRepo
 242   :: Verbosity
 243   -> VCS ConfiguredProgram
 244   -> SourceRepositoryPackage f
 245   -> [Char]
 246   -> IO ()
 247 cloneSourceRepo
 248   verbosity
 249   vcs
 250   repo@SourceRepositoryPackage{srpLocation = srcuri}
 251   destdir =
 252     traverse_ (runProgramInvocation verbosity) invocations
 253     where
 254       invocations =
 255         vcsCloneRepo
 256           vcs
 257           verbosity
 258           (vcsProgram vcs)
 259           repo
 260           srcuri
 261           destdir
 262
 263 -- | Synchronise a set of 'SourceRepo's referring to the same repository with
 264 -- corresponding local directories. The local directories may or may not
 265 -- already exist.
 266 --
 267 -- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos',
 268 -- or used across a series of invocations with any local directory must refer
 269 -- to the /same/ repository. That means it must be the same location but they
 270 -- can differ in the branch, or tag or subdir.
 271 --
 272 -- The reason to allow multiple related 'SourceRepo's is to allow for the
 273 -- network or storage to be shared between different checkouts of the repo.
 274 -- For example if a single repo contains multiple packages in different subdirs
 275 -- and in some project it may make sense to use a different state of the repo
 276 -- for one subdir compared to another.
 277 syncSourceRepos
 278   :: Verbosity
 279   -> VCS ConfiguredProgram
 280   -> [(SourceRepositoryPackage f, FilePath)]
 281   -> Rebuild ()
 282 syncSourceRepos verbosity vcs repos = do
 283   files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos
 284   monitorFiles files
 285
 286 -- ------------------------------------------------------------
 287
 288 -- * The various VCS drivers
 289
 290 -- ------------------------------------------------------------
 291
 292 -- | The set of all supported VCS drivers, organised by 'RepoType'.
 293 knownVCSs :: Map RepoType (VCS Program)
 294 knownVCSs = Map.fromList [(vcsRepoType vcs, vcs) | vcs <- vcss]
 295   where
 296     vcss = [vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn]
 297
 298 -- | VCS driver for Bazaar.
 299 vcsBzr :: VCS Program
 300 vcsBzr =
 301   VCS
 302     { vcsRepoType = KnownRepoType Bazaar
 303     , vcsProgram = bzrProgram
 304     , vcsCloneRepo
 305     , vcsSyncRepos
 306     }
 307   where
 308     vcsCloneRepo
 309       :: Verbosity
 310       -> ConfiguredProgram
 311       -> SourceRepositoryPackage f
 312       -> FilePath
 313       -> FilePath
 314       -> [ProgramInvocation]
 315     vcsCloneRepo verbosity prog repo srcuri destdir =
 316       [ programInvocation
 317           prog
 318           ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg)
 319       ]
 320       where
 321         -- The @get@ command was deprecated in version 2.4 in favour of
 322         -- the alias @branch@
 323         branchCmd
 324           | programVersion prog >= Just (mkVersion [2, 4]) =
 325               "branch"
 326           | otherwise = "get"
 327
 328         tagArgs :: [String]
 329         tagArgs = case srpTag repo of
 330           Nothing -> []
 331           Just tag -> ["-r", "tag:" ++ tag]
 332         verboseArg :: [String]
 333         verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 334
 335     vcsSyncRepos
 336       :: Verbosity
 337       -> ConfiguredProgram
 338       -> [(SourceRepositoryPackage f, FilePath)]
 339       -> IO [MonitorFilePath]
 340     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr"
 341
 342 bzrProgram :: Program
 343 bzrProgram =
 344   (simpleProgram "bzr")
 345     { programFindVersion = findProgramVersion "--version" $ \str ->
 346         case words str of
 347           -- "Bazaar (bzr) 2.6.0\n  ... lots of extra stuff"
 348           (_ : _ : ver : _) -> ver
 349           _ -> ""
 350     }
 351
 352 -- | VCS driver for Darcs.
 353 vcsDarcs :: VCS Program
 354 vcsDarcs =
 355   VCS
 356     { vcsRepoType = KnownRepoType Darcs
 357     , vcsProgram = darcsProgram
 358     , vcsCloneRepo
 359     , vcsSyncRepos
 360     }
 361   where
 362     vcsCloneRepo
 363       :: Verbosity
 364       -> ConfiguredProgram
 365       -> SourceRepositoryPackage f
 366       -> FilePath
 367       -> FilePath
 368       -> [ProgramInvocation]
 369     vcsCloneRepo verbosity prog repo srcuri destdir =
 370       [programInvocation prog cloneArgs]
 371       where
 372         cloneArgs :: [String]
 373         cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg
 374         -- At some point the @clone@ command was introduced as an alias for
 375         -- @get@, and @clone@ seems to be the recommended one now.
 376         cloneCmd :: String
 377         cloneCmd
 378           | programVersion prog >= Just (mkVersion [2, 8]) =
 379               "clone"
 380           | otherwise = "get"
 381         tagArgs :: [String]
 382         tagArgs = case srpTag repo of
 383           Nothing -> []
 384           Just tag -> ["-t", tag]
 385         verboseArg :: [String]
 386         verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 387
 388     vcsSyncRepos
 389       :: Verbosity
 390       -> ConfiguredProgram
 391       -> [(SourceRepositoryPackage f, FilePath)]
 392       -> IO [MonitorFilePath]
 393     vcsSyncRepos _ _ [] = return []
 394     vcsSyncRepos verbosity prog ((primaryRepo, primaryLocalDir) : secondaryRepos) =
 395       monitors <$ do
 396         vcsSyncRepo verbosity prog primaryRepo primaryLocalDir Nothing
 397         for_ secondaryRepos $ \(repo, localDir) ->
 398           vcsSyncRepo verbosity prog repo localDir $ Just primaryLocalDir
 399       where
 400         dirs :: [FilePath]
 401         dirs = primaryLocalDir : (snd <$> secondaryRepos)
 402         monitors :: [MonitorFilePath]
 403         monitors = monitorDirectoryExistence <$> dirs
 404
 405     vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer =
 406       try (lines <$> darcsWithOutput localDir ["log", "--last", "1"]) >>= \case
 407         Right (_ : _ : _ : x : _)
 408           | Just tag <- (List.stripPrefix "tagged " . List.dropWhile Char.isSpace) x
 409           , Just tag' <- srpTag
 410           , tag == tag' ->
 411               pure ()
 412         Left e | not (isDoesNotExistError e) -> throw e
 413         _ -> do
 414           removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw
 415           darcs (takeDirectory localDir) cloneArgs
 416       where
 417         darcs :: FilePath -> [String] -> IO ()
 418         darcs = darcs' runProgramInvocation
 419
 420         darcsWithOutput :: FilePath -> [String] -> IO String
 421         darcsWithOutput = darcs' getProgramInvocationOutput
 422
 423         darcs' :: (Verbosity -> ProgramInvocation -> t) -> FilePath -> [String] -> t
 424         darcs' f cwd args =
 425           f
 426             verbosity
 427             (programInvocation prog args)
 428               { progInvokeCwd = Just cwd
 429               }
 430
 431         cloneArgs :: [String]
 432         cloneArgs = ["clone"] ++ tagArgs ++ [srpLocation, localDir] ++ verboseArg
 433         tagArgs :: [String]
 434         tagArgs = case srpTag of
 435           Nothing -> []
 436           Just tag -> ["-t" ++ tag]
 437         verboseArg :: [String]
 438         verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 439
 440 darcsProgram :: Program
 441 darcsProgram =
 442   (simpleProgram "darcs")
 443     { programFindVersion = findProgramVersion "--version" $ \str ->
 444         case words str of
 445           -- "2.8.5 (release)"
 446           (ver : _) -> ver
 447           _ -> ""
 448     }
 449
 450 -- | VCS driver for Git.
 451 vcsGit :: VCS Program
 452 vcsGit =
 453   VCS
 454     { vcsRepoType = KnownRepoType Git
 455     , vcsProgram = gitProgram
 456     , vcsCloneRepo
 457     , vcsSyncRepos
 458     }
 459   where
 460     vcsCloneRepo
 461       :: Verbosity
 462       -> ConfiguredProgram
 463       -> SourceRepositoryPackage f
 464       -> FilePath
 465       -> FilePath
 466       -> [ProgramInvocation]
 467     vcsCloneRepo verbosity prog repo srcuri destdir =
 468       [programInvocation prog cloneArgs]
 469         -- And if there's a tag, we have to do that in a second step:
 470         ++ [git (resetArgs tag) | tag <- maybeToList (srpTag repo)]
 471         ++ [ git (["submodule", "sync", "--recursive"] ++ verboseArg)
 472            , git (["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg)
 473            ]
 474       where
 475         git args = (programInvocation prog args){progInvokeCwd = Just destdir}
 476         cloneArgs =
 477           ["clone", srcuri, destdir]
 478             ++ branchArgs
 479             ++ verboseArg
 480         branchArgs = case srpBranch repo of
 481           Just b -> ["--branch", b]
 482           Nothing -> []
 483         resetArgs tag = "reset" : verboseArg ++ ["--hard", tag, "--"]
 484         verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 485
 486     -- Note: No --depth=1 for vcsCloneRepo since that is used for `cabal get -s`,
 487     -- whereas `vcsSyncRepo` is used for source-repository-package where we do want shallow clones.
 488
 489     vcsSyncRepos
 490       :: Verbosity
 491       -> ConfiguredProgram
 492       -> [(SourceRepositoryPackage f, FilePath)]
 493       -> IO [MonitorFilePath]
 494     vcsSyncRepos _ _ [] = return []
 495     vcsSyncRepos
 496       verbosity
 497       gitProg
 498       ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
 499         vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing
 500         sequence_
 501           [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)
 502           | (repo, localDir) <- secondaryRepos
 503           ]
 504         return
 505           [ monitorDirectoryExistence dir
 506           | dir <- (primaryLocalDir : map snd secondaryRepos)
 507           ]
 508
 509     vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do
 510       exists <- doesDirectoryExist localDir
 511       if exists
 512         then git localDir ["fetch"]
 513         else git (takeDirectory localDir) cloneArgs
 514       -- Before trying to checkout other commits, all submodules must be
 515       -- de-initialised and the .git/modules directory must be deleted. This
 516       -- is needed because sometimes `git submodule sync` does not actually
 517       -- update the submodule source URL. Detailed description here:
 518       -- https://git.coop/-/snippets/85
 519       git localDir ["submodule", "deinit", "--force", "--all"]
 520       let gitModulesDir = localDir </> ".git" </> "modules"
 521       gitModulesExists <- doesDirectoryExist gitModulesDir
 522       when gitModulesExists $
 523         if buildOS == Windows
 524           then do
 525             -- Windows can't delete some git files #10182
 526             void $
 527               Process.createProcess_ "attrib" $
 528                 Process.shell $
 529                   "attrib -s -h -r " <> gitModulesDir <> "\\*.* /s /d"
 530
 531             catch
 532               (removePathForcibly gitModulesDir)
 533               (\e -> if isPermissionError e then removePathForcibly gitModulesDir else throw e)
 534           else removeDirectoryRecursive gitModulesDir
 535       when (resetTarget /= "HEAD") $ do
 536         git localDir fetchArgs -- first fetch the tag if needed
 537         git localDir setTagArgs
 538       git localDir resetArgs -- only then reset to the commit
 539       git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg
 540       git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg
 541       git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"]
 542       git localDir $ ["clean", "-ffxdq"]
 543       where
 544         git :: FilePath -> [String] -> IO ()
 545         git cwd args =
 546           runProgramInvocation verbosity $
 547             (programInvocation gitProg args)
 548               { progInvokeCwd = Just cwd
 549               }
 550
 551         cloneArgs =
 552           ["clone", "--depth=1", "--no-checkout", loc, localDir]
 553             ++ case peer of
 554               Nothing -> []
 555               Just peerLocalDir -> ["--reference", peerLocalDir]
 556             ++ verboseArg
 557           where
 558             loc = srpLocation
 559         -- To checkout/reset to a particular commit, we must first fetch it
 560         -- (since the base clone is shallow).
 561         fetchArgs = "fetch" : verboseArg ++ ["origin", resetTarget]
 562         -- And then create the Tag from the FETCH_HEAD (which we should have just fetched)
 563         setTagArgs = ["tag", "-f", resetTarget, "FETCH_HEAD"]
 564         -- Then resetting to that tag will work (if we don't create the tag
 565         -- locally from FETCH_HEAD, it won't exist).
 566         resetArgs = "reset" : verboseArg ++ ["--hard", resetTarget, "--"]
 567         resetTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)
 568         verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 569
 570 gitProgram :: Program
 571 gitProgram =
 572   (simpleProgram "git")
 573     { programFindVersion = findProgramVersion "--version" $ \str ->
 574         case words str of
 575           -- "git version 2.5.5"
 576           (_ : _ : ver : _) | all isTypical ver -> ver
 577           -- or annoyingly "git version 2.17.1.windows.2" yes, really
 578           (_ : _ : ver : _) ->
 579             intercalate "."
 580               . takeWhile (all isNum)
 581               . split
 582               $ ver
 583           _ -> ""
 584     }
 585   where
 586     isNum c = c >= '0' && c <= '9'
 587     isTypical c = isNum c || c == '.'
 588     split cs = case break (== '.') cs of
 589       (chunk, []) -> chunk : []
 590       (chunk, _ : rest) -> chunk : split rest
 591
 592 -- | VCS driver for Mercurial.
 593 vcsHg :: VCS Program
 594 vcsHg =
 595   VCS
 596     { vcsRepoType = KnownRepoType Mercurial
 597     , vcsProgram = hgProgram
 598     , vcsCloneRepo
 599     , vcsSyncRepos
 600     }
 601   where
 602     vcsCloneRepo
 603       :: Verbosity
 604       -> ConfiguredProgram
 605       -> SourceRepositoryPackage f
 606       -> FilePath
 607       -> FilePath
 608       -> [ProgramInvocation]
 609     vcsCloneRepo verbosity prog repo srcuri destdir =
 610       [programInvocation prog cloneArgs]
 611       where
 612         cloneArgs =
 613           ["clone", srcuri, destdir]
 614             ++ branchArgs
 615             ++ tagArgs
 616             ++ verboseArg
 617         branchArgs = case srpBranch repo of
 618           Just b -> ["--branch", b]
 619           Nothing -> []
 620         tagArgs = case srpTag repo of
 621           Just t -> ["--rev", t]
 622           Nothing -> []
 623         verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 624
 625     vcsSyncRepos
 626       :: Verbosity
 627       -> ConfiguredProgram
 628       -> [(SourceRepositoryPackage f, FilePath)]
 629       -> IO [MonitorFilePath]
 630     vcsSyncRepos _ _ [] = return []
 631     vcsSyncRepos
 632       verbosity
 633       hgProg
 634       ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
 635         vcsSyncRepo verbosity hgProg primaryRepo primaryLocalDir
 636         sequence_
 637           [ vcsSyncRepo verbosity hgProg repo localDir
 638           | (repo, localDir) <- secondaryRepos
 639           ]
 640         return
 641           [ monitorDirectoryExistence dir
 642           | dir <- (primaryLocalDir : map snd secondaryRepos)
 643           ]
 644     vcsSyncRepo verbosity hgProg repo localDir = do
 645       exists <- doesDirectoryExist localDir
 646       if exists
 647         then hg localDir ["pull"]
 648         else hg (takeDirectory localDir) cloneArgs
 649       hg localDir checkoutArgs
 650       where
 651         hg :: FilePath -> [String] -> IO ()
 652         hg cwd args =
 653           runProgramInvocation verbosity $
 654             (programInvocation hgProg args)
 655               { progInvokeCwd = Just cwd
 656               }
 657         cloneArgs =
 658           ["clone", "--noupdate", (srpLocation repo), localDir]
 659             ++ verboseArg
 660         verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 661         checkoutArgs =
 662           ["checkout", "--clean"]
 663             ++ tagArgs
 664         tagArgs = case srpTag repo of
 665           Just t -> ["--rev", t]
 666           Nothing -> []
 667
 668 hgProgram :: Program
 669 hgProgram =
 670   (simpleProgram "hg")
 671     { programFindVersion = findProgramVersion "--version" $ \str ->
 672         case words str of
 673           -- Mercurial Distributed SCM (version 3.5.2)\n ... long message
 674           (_ : _ : _ : _ : ver : _) -> takeWhile (\c -> Char.isDigit c || c == '.') ver
 675           _ -> ""
 676     }
 677
 678 -- | VCS driver for Subversion.
 679 vcsSvn :: VCS Program
 680 vcsSvn =
 681   VCS
 682     { vcsRepoType = KnownRepoType SVN
 683     , vcsProgram = svnProgram
 684     , vcsCloneRepo
 685     , vcsSyncRepos
 686     }
 687   where
 688     vcsCloneRepo
 689       :: Verbosity
 690       -> ConfiguredProgram
 691       -> SourceRepositoryPackage f
 692       -> FilePath
 693       -> FilePath
 694       -> [ProgramInvocation]
 695     vcsCloneRepo verbosity prog _repo srcuri destdir =
 696       [programInvocation prog checkoutArgs]
 697       where
 698         checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg
 699         verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 700     -- TODO: branch or tag?
 701
 702     vcsSyncRepos
 703       :: Verbosity
 704       -> ConfiguredProgram
 705       -> [(SourceRepositoryPackage f, FilePath)]
 706       -> IO [MonitorFilePath]
 707     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"
 708
 709 svnProgram :: Program
 710 svnProgram =
 711   (simpleProgram "svn")
 712     { programFindVersion = findProgramVersion "--version" $ \str ->
 713         case words str of
 714           -- svn, version 1.9.4 (r1740329)\n ... long message
 715           (_ : _ : ver : _) -> ver
 716           _ -> ""
 717     }
 718
 719 -- | VCS driver for Pijul.
 720 -- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>
 721 --
 722 -- 2020-04-09 Oleg:
 723 --
 724 --    As far as I understand pijul, there are branches and "tags" in pijul,
 725 --    but there aren't a "commit hash" identifying an arbitrary state.
 726 --
 727 --    One can create `a pijul tag`, which will make a patch hash,
 728 --    which depends on everything currently in the repository.
 729 --    I guess if you try to apply that patch, you'll be forced to apply
 730 --    all the dependencies too. In other words, there are no named tags.
 731 --
 732 --    It's not clear to me whether there is an option to
 733 --    "apply this patch *and* all of its dependencies".
 734 --    And relatedly, whether how to make sure that there are no other
 735 --    patches applied.
 736 --
 737 --    With branches it's easier, as you can `pull` and `checkout` them,
 738 --    and they seem to be similar enough. Yet, pijul documentations says
 739 --
 740 --    > Note that the purpose of branches in Pijul is quite different from Git,
 741 --      since Git's "feature branches" can usually be implemented by just
 742 --      patches.
 743 --
 744 --    I guess it means that indeed instead of creating a branch and making PR
 745 --    in "GitHub" workflow, you'd just create a patch and offer it.
 746 --    You can do that with `git` too. Push (a branch with) commit to remote
 747 --    and ask other to cherry-pick that commit. Yet, in git identity of commit
 748 --    changes when it applied to other trees, where patches in pijul have
 749 --    will continue to have the same hash.
 750 --
 751 --    Unfortunately pijul doesn't talk about conflict resolution.
 752 --    It seems that you get something like:
 753 --
 754 --        % pijul status
 755 --        On branch merge
 756 --
 757 --        Unresolved conflicts:
 758 --          (fix conflicts and record the resolution with "pijul record ...")
 759 --
 760 --                foo
 761 --
 762 --        % cat foo
 763 --        first line
 764 --        >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 765 --        branch BBB
 766 --        ================================
 767 --        branch AAA
 768 --        <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 769 --        last line
 770 --
 771 --    And then the `pijul dependencies` would draw you a graph like
 772 --
 773 --
 774 --                    ----->  foo on branch B ----->
 775 --    resolve conflict                                  Initial patch
 776 --                    ----->  foo on branch A ----->
 777 --
 778 --    Which is seems reasonable.
 779 --
 780 --    So currently, pijul support is very experimental, and most likely
 781 --    won't work, even the basics are in place. Tests are also written
 782 --    but disabled, as the branching model differs from `git` one,
 783 --    for which tests are written.
 784 vcsPijul :: VCS Program
 785 vcsPijul =
 786   VCS
 787     { vcsRepoType = KnownRepoType Pijul
 788     , vcsProgram = pijulProgram
 789     , vcsCloneRepo
 790     , vcsSyncRepos
 791     }
 792   where
 793     vcsCloneRepo
 794       :: Verbosity
 795       -- \^ it seems that pijul does not have verbose flag
 796       -> ConfiguredProgram
 797       -> SourceRepositoryPackage f
 798       -> FilePath
 799       -> FilePath
 800       -> [ProgramInvocation]
 801     vcsCloneRepo _verbosity prog repo srcuri destdir =
 802       [programInvocation prog cloneArgs]
 803         -- And if there's a tag, we have to do that in a second step:
 804         ++ [ (programInvocation prog (checkoutArgs tag))
 805             { progInvokeCwd = Just destdir
 806             }
 807            | tag <- maybeToList (srpTag repo)
 808            ]
 809       where
 810         cloneArgs :: [String]
 811         cloneArgs =
 812           ["clone", srcuri, destdir]
 813             ++ branchArgs
 814         branchArgs :: [String]
 815         branchArgs = case srpBranch repo of
 816           Just b -> ["--from-branch", b]
 817           Nothing -> []
 818         checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either
 819     vcsSyncRepos
 820       :: Verbosity
 821       -> ConfiguredProgram
 822       -> [(SourceRepositoryPackage f, FilePath)]
 823       -> IO [MonitorFilePath]
 824     vcsSyncRepos _ _ [] = return []
 825     vcsSyncRepos
 826       verbosity
 827       pijulProg
 828       ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
 829         vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing
 830         sequence_
 831           [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)
 832           | (repo, localDir) <- secondaryRepos
 833           ]
 834         return
 835           [ monitorDirectoryExistence dir
 836           | dir <- (primaryLocalDir : map snd secondaryRepos)
 837           ]
 838
 839     vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do
 840       exists <- doesDirectoryExist localDir
 841       if exists
 842         then pijul localDir ["pull"] -- TODO: this probably doesn't work.
 843         else pijul (takeDirectory localDir) cloneArgs
 844       pijul localDir checkoutArgs
 845       where
 846         pijul :: FilePath -> [String] -> IO ()
 847         pijul cwd args =
 848           runProgramInvocation verbosity $
 849             (programInvocation pijulProg args)
 850               { progInvokeCwd = Just cwd
 851               }
 852
 853         cloneArgs :: [String]
 854         cloneArgs =
 855           ["clone", loc, localDir]
 856             ++ case peer of
 857               Nothing -> []
 858               Just peerLocalDir -> [peerLocalDir]
 859           where
 860             loc = srpLocation
 861         checkoutArgs :: [String]
 862         checkoutArgs = "checkout" : ["--force", checkoutTarget, "--"]
 863         checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong.
 864
 865 pijulProgram :: Program
 866 pijulProgram =
 867   (simpleProgram "pijul")
 868     { programFindVersion = findProgramVersion "--version" $ \str ->
 869         case words str of
 870           -- "pijul 0.12.2
 871           (_ : ver : _) | all isTypical ver -> ver
 872           _ -> ""
 873     }
 874   where
 875     isNum c = c >= '0' && c <= '9'
 876     isTypical c = isNum c || c == '.'