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