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