cabal-install/tests/UnitTests/Distribution/Client/VCS.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE KindSignatures #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE TypeApplications #-}
   8
   9 module UnitTests.Distribution.Client.VCS (tests) where
  10
  11 import Distribution.Client.Compat.Prelude
  12 import Distribution.Client.RebuildMonad
  13   ( execRebuild
  14   )
  15 import Distribution.Client.Types.SourceRepo (SourceRepoProxy, SourceRepositoryPackage (..))
  16 import Distribution.Client.VCS
  17 import Distribution.Simple.Program
  18 import Distribution.System (OS (Windows), buildOS)
  19 import Distribution.Verbosity as Verbosity
  20 import Test.Utils.TempTestDir (removeDirectoryRecursiveHack, withTestDir)
  21
  22 import Data.List (mapAccumL)
  23 import qualified Data.Map as Map
  24 import qualified Data.Set as Set
  25 import Data.Tuple
  26
  27 import Control.Concurrent (threadDelay)
  28 import Control.Exception
  29 import Control.Monad.State (StateT, execStateT, liftIO)
  30 import qualified Control.Monad.State as State
  31
  32 import System.Directory
  33 import System.FilePath
  34 import System.IO
  35 import System.Random
  36
  37 import Test.Tasty
  38 import Test.Tasty.ExpectedFailure
  39 import Test.Tasty.QuickCheck
  40 import UnitTests.Distribution.Client.ArbitraryInstances
  41
  42 -- | These tests take the following approach: we generate a pure representation
  43 -- of a repository plus a corresponding real repository, and then run various
  44 -- test operations and compare the actual working state with the expected
  45 -- working state.
  46 --
  47 -- The first test simply checks that the test infrastructure works. It
  48 -- constructs a repository on disk and then checks out every tag or commit
  49 -- and checks that the working state is the same as the pure representation.
  50 --
  51 -- The second test works in a similar way but tests 'syncSourceRepos'. It
  52 -- uses an arbitrary source repo and a set of (initially empty) destination
  53 -- directories. It picks a number of tags or commits from the source repo and
  54 -- synchronises the destination directories to those target states, and then
  55 -- checks that the working state is as expected (given the pure representation).
  56 tests :: MTimeChange -> [TestTree]
  57 tests mtimeChange =
  58   map
  59     (localOption $ QuickCheckTests 10)
  60     [ ignoreInWindows "See issue #8048 and #9519" $
  61         testGroup
  62           "git"
  63           [ testProperty "check VCS test framework" prop_framework_git
  64           , testProperty "cloneSourceRepo" prop_cloneRepo_git
  65           , testProperty "syncSourceRepos" prop_syncRepos_git
  66           ]
  67     , --
  68       ignoreTestBecause "for the moment they're not yet working" $
  69         testGroup
  70           "darcs"
  71           [ testProperty "check VCS test framework" $ prop_framework_darcs mtimeChange
  72           , testProperty "cloneSourceRepo" $ prop_cloneRepo_darcs mtimeChange
  73           , testProperty "syncSourceRepos" $ prop_syncRepos_darcs mtimeChange
  74           ]
  75     , ignoreTestBecause "for the moment they're not yet working" $
  76         testGroup
  77           "pijul"
  78           [ testProperty "check VCS test framework" prop_framework_pijul
  79           , testProperty "cloneSourceRepo" prop_cloneRepo_pijul
  80           , testProperty "syncSourceRepos" prop_syncRepos_pijul
  81           ]
  82     , ignoreTestBecause "for the moment they're not yet working" $
  83         testGroup
  84           "mercurial"
  85           [ testProperty "check VCS test framework" prop_framework_hg
  86           , testProperty "cloneSourceRepo" prop_cloneRepo_hg
  87           , testProperty "syncSourceRepos" prop_syncRepos_hg
  88           ]
  89     ]
  90   where
  91     ignoreInWindows msg = case buildOS of
  92       Windows -> ignoreTestBecause msg
  93       _ -> id
  94
  95 prop_framework_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property
  96 prop_framework_git =
  97   ioProperty
  98     . prop_framework vcsGit vcsTestDriverGit
  99     . WithBranchingSupport
 100
 101 prop_framework_darcs :: MTimeChange -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property
 102 prop_framework_darcs mtimeChange =
 103   ioProperty
 104     . prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange)
 105     . WithoutBranchingSupport
 106
 107 prop_framework_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property
 108 prop_framework_pijul =
 109   ioProperty
 110     . prop_framework vcsPijul vcsTestDriverPijul
 111     . WithBranchingSupport
 112
 113 prop_framework_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property
 114 prop_framework_hg =
 115   ioProperty
 116     . prop_framework vcsHg vcsTestDriverHg
 117     . WithBranchingSupport
 118
 119 prop_cloneRepo_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property
 120 prop_cloneRepo_git =
 121   ioProperty
 122     . prop_cloneRepo vcsGit vcsTestDriverGit
 123     . WithBranchingSupport
 124
 125 prop_cloneRepo_darcs
 126   :: MTimeChange
 127   -> NonBranchingRepoRecipe 'SubmodulesNotSupported
 128   -> Property
 129 prop_cloneRepo_darcs mtimeChange =
 130   ioProperty
 131     . prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange)
 132     . WithoutBranchingSupport
 133
 134 prop_cloneRepo_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property
 135 prop_cloneRepo_pijul =
 136   ioProperty
 137     . prop_cloneRepo vcsPijul vcsTestDriverPijul
 138     . WithBranchingSupport
 139
 140 prop_cloneRepo_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property
 141 prop_cloneRepo_hg =
 142   ioProperty
 143     . prop_cloneRepo vcsHg vcsTestDriverHg
 144     . WithBranchingSupport
 145
 146 prop_syncRepos_git
 147   :: RepoDirSet
 148   -> SyncTargetIterations
 149   -> PrngSeed
 150   -> BranchingRepoRecipe 'SubmodulesSupported
 151   -> Property
 152 prop_syncRepos_git destRepoDirs syncTargetSetIterations seed =
 153   ioProperty
 154     . prop_syncRepos
 155       vcsGit
 156       vcsTestDriverGit
 157       destRepoDirs
 158       syncTargetSetIterations
 159       seed
 160     . WithBranchingSupport
 161
 162 prop_syncRepos_darcs
 163   :: MTimeChange
 164   -> RepoDirSet
 165   -> SyncTargetIterations
 166   -> PrngSeed
 167   -> NonBranchingRepoRecipe 'SubmodulesNotSupported
 168   -> Property
 169 prop_syncRepos_darcs mtimeChange destRepoDirs syncTargetSetIterations seed =
 170   ioProperty
 171     . prop_syncRepos
 172       vcsDarcs
 173       (vcsTestDriverDarcs mtimeChange)
 174       destRepoDirs
 175       syncTargetSetIterations
 176       seed
 177     . WithoutBranchingSupport
 178
 179 prop_syncRepos_pijul
 180   :: RepoDirSet
 181   -> SyncTargetIterations
 182   -> PrngSeed
 183   -> BranchingRepoRecipe 'SubmodulesNotSupported
 184   -> Property
 185 prop_syncRepos_pijul destRepoDirs syncTargetSetIterations seed =
 186   ioProperty
 187     . prop_syncRepos
 188       vcsPijul
 189       vcsTestDriverPijul
 190       destRepoDirs
 191       syncTargetSetIterations
 192       seed
 193     . WithBranchingSupport
 194
 195 prop_syncRepos_hg
 196   :: RepoDirSet
 197   -> SyncTargetIterations
 198   -> PrngSeed
 199   -> BranchingRepoRecipe 'SubmodulesNotSupported
 200   -> Property
 201 prop_syncRepos_hg destRepoDirs syncTargetSetIterations seed =
 202   ioProperty
 203     . prop_syncRepos
 204       vcsHg
 205       vcsTestDriverHg
 206       destRepoDirs
 207       syncTargetSetIterations
 208       seed
 209     . WithBranchingSupport
 210
 211 -- ------------------------------------------------------------
 212
 213 -- * General test setup
 214
 215 -- ------------------------------------------------------------
 216
 217 testSetup
 218   :: VCS Program
 219   -> ( Verbosity
 220        -> VCS ConfiguredProgram
 221        -> FilePath
 222        -> FilePath
 223        -> VCSTestDriver
 224      )
 225   -> RepoRecipe submodules
 226   -> (VCSTestDriver -> FilePath -> RepoState -> IO a)
 227   -> IO a
 228 testSetup vcs mkVCSTestDriver repoRecipe theTest = do
 229   -- test setup
 230   vcs' <- configureVCS verbosity [] vcs
 231   withTestDir verbosity "vcstest" $ \tmpdir -> do
 232     let srcRepoPath = tmpdir </> "src"
 233         submodulesPath = tmpdir </> "submodules"
 234         vcsDriver = mkVCSTestDriver verbosity vcs' submodulesPath srcRepoPath
 235     repoState <- createRepo vcsDriver repoRecipe
 236
 237     -- actual test
 238     result <- theTest vcsDriver tmpdir repoState
 239
 240     return result
 241   where
 242     verbosity = silent
 243
 244 -- ------------------------------------------------------------
 245
 246 -- * Test 1: VCS infrastructure
 247
 248 -- ------------------------------------------------------------
 249
 250 -- | This test simply checks that the test infrastructure works. It constructs
 251 -- a repository on disk and then checks out every tag or commit and checks that
 252 -- the working state is the same as the pure representation.
 253 prop_framework
 254   :: VCS Program
 255   -> ( Verbosity
 256        -> VCS ConfiguredProgram
 257        -> FilePath
 258        -> FilePath
 259        -> VCSTestDriver
 260      )
 261   -> RepoRecipe submodules
 262   -> IO ()
 263 prop_framework vcs mkVCSTestDriver repoRecipe =
 264   testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
 265     mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))
 266   where
 267     -- Check for any given tag/commit in the 'RepoState' that the working state
 268     -- matches the actual working state from the repository at that tag/commit.
 269     checkAtTag VCSTestDriver{..} tmpdir (tagname, expectedState) =
 270       case vcsCheckoutTag of
 271         -- We handle two cases: inplace checkouts for VCSs that support it
 272         -- (e.g. git) and separate dir otherwise (e.g. darcs)
 273         Left checkoutInplace -> do
 274           checkoutInplace tagname
 275           checkExpectedWorkingState vcsIgnoreFiles vcsRepoRoot expectedState
 276         Right checkoutCloneTo -> do
 277           checkoutCloneTo tagname destRepoPath
 278           checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState
 279           removeDirectoryRecursiveHack silent destRepoPath
 280       where
 281         destRepoPath = tmpdir </> "dest"
 282
 283 -- ------------------------------------------------------------
 284
 285 -- * Test 2: 'cloneSourceRepo'
 286
 287 -- ------------------------------------------------------------
 288
 289 prop_cloneRepo
 290   :: VCS Program
 291   -> ( Verbosity
 292        -> VCS ConfiguredProgram
 293        -> FilePath
 294        -> FilePath
 295        -> VCSTestDriver
 296      )
 297   -> RepoRecipe submodules
 298   -> IO ()
 299 prop_cloneRepo vcs mkVCSTestDriver repoRecipe =
 300   testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
 301     mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))
 302   where
 303     checkAtTag VCSTestDriver{..} tmpdir (tagname, expectedState) = do
 304       cloneSourceRepo verbosity vcsVCS repo destRepoPath
 305       checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState
 306       removeDirectoryRecursiveHack verbosity destRepoPath
 307       where
 308         destRepoPath = tmpdir </> "dest"
 309         repo =
 310           SourceRepositoryPackage
 311             { srpType = vcsRepoType vcsVCS
 312             , srpLocation = vcsRepoRoot
 313             , srpTag = Just tagname
 314             , srpBranch = Nothing
 315             , srpSubdir = []
 316             , srpCommand = []
 317             }
 318     verbosity = silent
 319
 320 -- ------------------------------------------------------------
 321
 322 -- * Test 3: 'syncSourceRepos'
 323
 324 -- ------------------------------------------------------------
 325
 326 newtype RepoDirSet = RepoDirSet Int deriving (Show)
 327 newtype SyncTargetIterations = SyncTargetIterations Int deriving (Show)
 328 newtype PrngSeed = PrngSeed Int deriving (Show)
 329
 330 prop_syncRepos
 331   :: VCS Program
 332   -> ( Verbosity
 333        -> VCS ConfiguredProgram
 334        -> FilePath
 335        -> FilePath
 336        -> VCSTestDriver
 337      )
 338   -> RepoDirSet
 339   -> SyncTargetIterations
 340   -> PrngSeed
 341   -> RepoRecipe submodules
 342   -> IO ()
 343 prop_syncRepos
 344   vcs
 345   mkVCSTestDriver
 346   repoDirs
 347   syncTargetSetIterations
 348   seed
 349   repoRecipe =
 350     testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
 351       let srcRepoPath = vcsRepoRoot vcsDriver
 352           destRepoPaths = map (tmpdir </>) (getRepoDirs repoDirs)
 353        in checkSyncRepos
 354             verbosity
 355             vcsDriver
 356             repoState
 357             srcRepoPath
 358             destRepoPaths
 359             syncTargetSetIterations
 360             seed
 361     where
 362       verbosity = silent
 363
 364       getRepoDirs :: RepoDirSet -> [FilePath]
 365       getRepoDirs (RepoDirSet n) =
 366         ["dest" ++ show i | i <- [1 .. n]]
 367
 368 -- | The purpose of this test is to check that irrespective of the local cached
 369 -- repo dir we can sync it to an arbitrary target state. So we do that by
 370 -- syncing each target dir to a sequence of target states without cleaning it
 371 -- in between.
 372 --
 373 -- One slight complication is that 'syncSourceRepos' takes a whole list of
 374 -- target dirs to sync in one go (to allow for sharing). So we must actually
 375 -- generate and sync to a sequence of list of target repo states.
 376 --
 377 -- So, given a source repo dir, the corresponding 'RepoState' and a number of
 378 -- target repo dirs, pick a sequence of (lists of) sync targets from the
 379 -- 'RepoState' and synchronise the target dirs with those targets, checking for
 380 -- each one that the actual working state matches the expected repo state.
 381 checkSyncRepos
 382   :: Verbosity
 383   -> VCSTestDriver
 384   -> RepoState
 385   -> FilePath
 386   -> [FilePath]
 387   -> SyncTargetIterations
 388   -> PrngSeed
 389   -> IO ()
 390 checkSyncRepos
 391   verbosity
 392   VCSTestDriver{vcsVCS = vcs, vcsIgnoreFiles}
 393   repoState
 394   srcRepoPath
 395   destRepoPath
 396   (SyncTargetIterations syncTargetSetIterations)
 397   (PrngSeed seed) =
 398     mapM_ checkSyncTargetSet syncTargetSets
 399     where
 400       checkSyncTargetSet :: [(SourceRepoProxy, FilePath, RepoWorkingState)] -> IO ()
 401       checkSyncTargetSet syncTargets = do
 402         _ <-
 403           execRebuild "root-unused" $
 404             syncSourceRepos
 405               verbosity
 406               vcs
 407               [ (repo, repoPath)
 408               | (repo, repoPath, _) <- syncTargets
 409               ]
 410         sequence_
 411           [ checkExpectedWorkingState vcsIgnoreFiles repoPath workingState
 412           | (_, repoPath, workingState) <- syncTargets
 413           ]
 414
 415       syncTargetSets =
 416         take syncTargetSetIterations $
 417           pickSyncTargetSets
 418             (vcsRepoType vcs)
 419             repoState
 420             srcRepoPath
 421             destRepoPath
 422             (mkStdGen seed)
 423
 424 pickSyncTargetSets
 425   :: RepoType
 426   -> RepoState
 427   -> FilePath
 428   -> [FilePath]
 429   -> StdGen
 430   -> [[(SourceRepoProxy, FilePath, RepoWorkingState)]]
 431 pickSyncTargetSets repoType repoState srcRepoPath dstReposPath =
 432   assert (Map.size (allTags repoState) > 0) $
 433     unfoldr (Just . swap . pickSyncTargetSet)
 434   where
 435     pickSyncTargetSet :: Rand [(SourceRepoProxy, FilePath, RepoWorkingState)]
 436     pickSyncTargetSet = flip (mapAccumL (flip pickSyncTarget)) dstReposPath
 437
 438     pickSyncTarget :: FilePath -> Rand (SourceRepoProxy, FilePath, RepoWorkingState)
 439     pickSyncTarget destRepoPath prng =
 440       (prng', (repo, destRepoPath, workingState))
 441       where
 442         repo =
 443           SourceRepositoryPackage
 444             { srpType = repoType
 445             , srpLocation = srcRepoPath
 446             , srpTag = Just tag
 447             , srpBranch = Nothing
 448             , srpSubdir = Proxy
 449             , srpCommand = []
 450             }
 451         (tag, workingState) = Map.elemAt tagIdx (allTags repoState)
 452         (tagIdx, prng') = randomR (0, Map.size (allTags repoState) - 1) prng
 453
 454 type Rand a = StdGen -> (StdGen, a)
 455
 456 instance Arbitrary RepoDirSet where
 457   arbitrary =
 458     sized $ \n ->
 459       oneof $
 460         [RepoDirSet <$> pure 1]
 461           ++ [RepoDirSet <$> choose (2, 5) | n >= 3]
 462   shrink (RepoDirSet n) =
 463     [RepoDirSet i | i <- shrink n, i > 0]
 464
 465 instance Arbitrary SyncTargetIterations where
 466   arbitrary =
 467     sized $ \n -> SyncTargetIterations <$> elements [1 .. min 20 (n + 1)]
 468   shrink (SyncTargetIterations n) =
 469     [SyncTargetIterations i | i <- shrink n, i > 0]
 470
 471 instance Arbitrary PrngSeed where
 472   arbitrary = PrngSeed <$> arbitraryBoundedRandom
 473
 474 -- ------------------------------------------------------------
 475
 476 -- * Instructions for constructing repositories
 477
 478 -- ------------------------------------------------------------
 479
 480 -- These instructions for constructing a repository can be interpreted in two
 481 -- ways: to make a pure representation of repository state, and to execute
 482 -- VCS commands to make a repository on-disk.
 483
 484 data SubmodulesSupport = SubmodulesSupported | SubmodulesNotSupported
 485
 486 class KnownSubmodulesSupport (a :: SubmodulesSupport) where
 487   submoduleSupport :: SubmodulesSupport
 488
 489 instance KnownSubmodulesSupport 'SubmodulesSupported where
 490   submoduleSupport = SubmodulesSupported
 491
 492 instance KnownSubmodulesSupport 'SubmodulesNotSupported where
 493   submoduleSupport = SubmodulesNotSupported
 494
 495 data FileUpdate = FileUpdate FilePath String
 496   deriving (Show)
 497 data SubmoduleAdd = SubmoduleAdd FilePath FilePath (Commit 'SubmodulesSupported)
 498   deriving (Show)
 499
 500 newtype Commit (submodules :: SubmodulesSupport)
 501   = Commit [Either FileUpdate SubmoduleAdd]
 502   deriving (Show)
 503
 504 data TaggedCommits (submodules :: SubmodulesSupport)
 505   = TaggedCommits TagName [Commit submodules]
 506   deriving (Show)
 507
 508 data BranchCommits (submodules :: SubmodulesSupport)
 509   = BranchCommits BranchName [Commit submodules]
 510   deriving (Show)
 511
 512 type BranchName = String
 513 type TagName = String
 514
 515 -- | Instructions to make a repository without branches, for VCSs that do not
 516 -- support branches (e.g. darcs).
 517 newtype NonBranchingRepoRecipe submodules
 518   = NonBranchingRepoRecipe [TaggedCommits submodules]
 519   deriving (Show)
 520
 521 -- | Instructions to make a repository with branches, for VCSs that do
 522 -- support branches (e.g. git).
 523 newtype BranchingRepoRecipe submodules
 524   = BranchingRepoRecipe [Either (TaggedCommits submodules) (BranchCommits submodules)]
 525   deriving (Show)
 526
 527 data RepoRecipe submodules
 528   = WithBranchingSupport (BranchingRepoRecipe submodules)
 529   | WithoutBranchingSupport (NonBranchingRepoRecipe submodules)
 530   deriving (Show)
 531
 532 -- ---------------------------------------------------------------------------
 533 -- Arbitrary instances for them
 534
 535 genFileName :: Gen FilePath
 536 genFileName = (\c -> "file" </> [c]) <$> choose ('A', 'E')
 537
 538 instance Arbitrary FileUpdate where
 539   arbitrary = genOnlyFileUpdate
 540     where
 541       genOnlyFileUpdate = FileUpdate <$> genFileName <*> genFileContent
 542       genFileContent = vectorOf 10 (choose ('#', '~'))
 543
 544 instance Arbitrary SubmoduleAdd where
 545   arbitrary = genOnlySubmoduleAdd
 546     where
 547       genOnlySubmoduleAdd = SubmoduleAdd <$> genFileName <*> genSubmoduleSrc <*> arbitrary
 548       genSubmoduleSrc = vectorOf 20 (choose ('a', 'z'))
 549
 550 instance forall submodules. KnownSubmodulesSupport submodules => Arbitrary (Commit submodules) where
 551   arbitrary = Commit <$> shortListOf1 5 fileUpdateOrSubmoduleAdd
 552     where
 553       fileUpdateOrSubmoduleAdd =
 554         case submoduleSupport @submodules of
 555           SubmodulesSupported ->
 556             frequency
 557               [ (10, Left <$> arbitrary)
 558               , (1, Right <$> arbitrary)
 559               ]
 560           SubmodulesNotSupported -> Left <$> arbitrary
 561   shrink (Commit writes) = Commit <$> filter (not . null) (shrink writes)
 562
 563 instance KnownSubmodulesSupport submodules => Arbitrary (TaggedCommits submodules) where
 564   arbitrary = TaggedCommits <$> genTagName <*> shortListOf1 5 arbitrary
 565     where
 566       genTagName = ("tag_" ++) <$> shortListOf1 5 (choose ('A', 'Z'))
 567   shrink (TaggedCommits tag commits) =
 568     TaggedCommits tag <$> filter (not . null) (shrink commits)
 569
 570 instance KnownSubmodulesSupport submodules => Arbitrary (BranchCommits submodules) where
 571   arbitrary = BranchCommits <$> genBranchName <*> shortListOf1 5 arbitrary
 572     where
 573       genBranchName =
 574         sized $ \n ->
 575           (\c -> "branch_" ++ [c]) <$> elements (take (max 1 n) ['A' .. 'E'])
 576
 577   shrink (BranchCommits branch commits) =
 578     BranchCommits branch <$> filter (not . null) (shrink commits)
 579
 580 instance KnownSubmodulesSupport submodules => Arbitrary (NonBranchingRepoRecipe submodules) where
 581   arbitrary = NonBranchingRepoRecipe <$> shortListOf1 15 arbitrary
 582   shrink (NonBranchingRepoRecipe xs) =
 583     NonBranchingRepoRecipe <$> filter (not . null) (shrink xs)
 584
 585 instance KnownSubmodulesSupport submodules => Arbitrary (BranchingRepoRecipe submodules) where
 586   arbitrary = BranchingRepoRecipe <$> shortListOf1 15 taggedOrBranch
 587     where
 588       taggedOrBranch =
 589         frequency
 590           [ (3, Left <$> arbitrary)
 591           , (1, Right <$> arbitrary)
 592           ]
 593   shrink (BranchingRepoRecipe xs) =
 594     BranchingRepoRecipe <$> filter (not . null) (shrink xs)
 595
 596 -- ------------------------------------------------------------
 597
 598 -- * A pure model of repository state
 599
 600 -- ------------------------------------------------------------
 601
 602 -- | The full state of a repository. In particular it records the full working
 603 -- state for every tag.
 604 --
 605 -- This is also the interpreter state for executing a 'RepoRecipe'.
 606 --
 607 -- This allows us to compare expected working states with the actual files in
 608 -- the working directory of a repository. See 'checkExpectedWorkingState'.
 609 data RepoState = RepoState
 610   { currentBranch :: BranchName
 611   , currentWorking :: RepoWorkingState
 612   , allTags :: Map TagOrCommitId RepoWorkingState
 613   , allBranches :: Map BranchName RepoWorkingState
 614   }
 615   deriving (Show)
 616
 617 type RepoWorkingState = Map FilePath String
 618 type CommitId = String
 619 type TagOrCommitId = String
 620
 621 ------------------------------------------------------------------------------
 622 -- Functions used to interpret instructions for constructing repositories
 623
 624 initialRepoState :: RepoState
 625 initialRepoState =
 626   RepoState
 627     { currentBranch = "branch_master"
 628     , currentWorking = Map.empty
 629     , allTags = Map.empty
 630     , allBranches = Map.empty
 631     }
 632
 633 updateFile :: FilePath -> String -> RepoState -> RepoState
 634 updateFile filename content state@RepoState{currentWorking} =
 635   let removeSubmodule = Map.filterWithKey (\path _ -> not $ filename `isPrefixOf` path) currentWorking
 636    in state{currentWorking = Map.insert filename content removeSubmodule}
 637
 638 addSubmodule :: FilePath -> RepoState -> RepoState -> RepoState
 639 addSubmodule submodulePath submoduleState mainState =
 640   let newFiles = Map.mapKeys (submodulePath </>) (currentWorking submoduleState)
 641       removeSubmodule = Map.filterWithKey (\path _ -> not $ submodulePath `isPrefixOf` path) (currentWorking mainState)
 642       newWorking = Map.union removeSubmodule newFiles
 643    in mainState{currentWorking = newWorking}
 644
 645 addTagOrCommit :: TagOrCommitId -> RepoState -> RepoState
 646 addTagOrCommit commit state@RepoState{currentWorking, allTags} =
 647   state{allTags = Map.insert commit currentWorking allTags}
 648
 649 switchBranch :: BranchName -> RepoState -> RepoState
 650 switchBranch branch state@RepoState{currentWorking, currentBranch, allBranches} =
 651   -- Use updated allBranches to cover case of switching to the same branch
 652   let allBranches' = Map.insert currentBranch currentWorking allBranches
 653    in state
 654         { currentBranch = branch
 655         , currentWorking = case Map.lookup branch allBranches' of
 656             Just working -> working
 657             -- otherwise we're creating a new branch, which starts
 658             -- from our current branch state
 659             Nothing -> currentWorking
 660         , allBranches = allBranches'
 661         }
 662
 663 -- ------------------------------------------------------------
 664
 665 -- * Comparing on-disk with expected 'RepoWorkingState'
 666
 667 -- ------------------------------------------------------------
 668
 669 -- | Compare expected working states with the actual files in
 670 -- the working directory of a repository.
 671 checkExpectedWorkingState
 672   :: Set FilePath
 673   -> FilePath
 674   -> RepoWorkingState
 675   -> IO ()
 676 checkExpectedWorkingState ignore repoPath expectedState = do
 677   currentState <- getCurrentWorkingState ignore repoPath
 678   unless (currentState == expectedState) $
 679     throwIO (WorkingStateMismatch expectedState currentState)
 680
 681 data WorkingStateMismatch
 682   = WorkingStateMismatch
 683       RepoWorkingState -- expected
 684       RepoWorkingState -- actual
 685   deriving (Show)
 686
 687 instance Exception WorkingStateMismatch
 688
 689 getCurrentWorkingState :: Set FilePath -> FilePath -> IO RepoWorkingState
 690 getCurrentWorkingState ignore repoRoot = do
 691   entries <- getDirectoryContentsRecursive ignore repoRoot ""
 692   Map.fromList
 693     <$> mapM
 694       getFileEntry
 695       [file | (file, isDir) <- entries, not isDir]
 696   where
 697     getFileEntry name =
 698       withBinaryFile (repoRoot </> name) ReadMode $ \h -> do
 699         str <- hGetContents h
 700         _ <- evaluate (length str)
 701         return (name, str)
 702
 703 getDirectoryContentsRecursive
 704   :: Set FilePath
 705   -> FilePath
 706   -> FilePath
 707   -> IO [(FilePath, Bool)]
 708 getDirectoryContentsRecursive ignore dir0 dir = do
 709   entries <- getDirectoryContents (dir0 </> dir)
 710   entries' <-
 711     sequence
 712       [ do
 713         isdir <- doesDirectoryExist (dir0 </> dir </> entry)
 714         return (dir </> entry, isdir)
 715       | entry <- entries
 716       , not (isPrefixOf "." entry)
 717       , (dir </> entry) `Set.notMember` ignore
 718       ]
 719   let subdirs = [d | (d, True) <- entries']
 720   subdirEntries <- mapM (getDirectoryContentsRecursive ignore dir0) subdirs
 721   return (concat (entries' : subdirEntries))
 722
 723 -- ------------------------------------------------------------
 724
 725 -- * Executing instructions to make on-disk VCS repos
 726
 727 -- ------------------------------------------------------------
 728
 729 -- | Execute the instructions in a 'RepoRecipe' using the given 'VCSTestDriver'
 730 -- to make an on-disk repository.
 731 --
 732 -- This also returns a 'RepoState'. This is done as part of construction to
 733 -- support VCSs like git that have commit ids, so that those commit ids can be
 734 -- included in the 'RepoState's 'allTags' set.
 735 createRepo :: VCSTestDriver -> RepoRecipe submodules -> IO RepoState
 736 createRepo vcsDriver@VCSTestDriver{vcsRepoRoot, vcsInit} recipe = do
 737   createDirectoryIfMissing True vcsRepoRoot
 738   createDirectoryIfMissing True (vcsRepoRoot </> "file")
 739   vcsInit
 740   execStateT createRepoAction initialRepoState
 741   where
 742     createRepoAction :: StateT RepoState IO ()
 743     createRepoAction = case recipe of
 744       WithoutBranchingSupport r -> execNonBranchingRepoRecipe vcsDriver r
 745       WithBranchingSupport r -> execBranchingRepoRecipe vcsDriver r
 746
 747 type CreateRepoAction a = VCSTestDriver -> a -> StateT RepoState IO ()
 748
 749 execNonBranchingRepoRecipe :: CreateRepoAction (NonBranchingRepoRecipe submodules)
 750 execNonBranchingRepoRecipe vcsDriver (NonBranchingRepoRecipe taggedCommits) =
 751   mapM_ (execTaggdCommits vcsDriver) taggedCommits
 752
 753 execBranchingRepoRecipe :: CreateRepoAction (BranchingRepoRecipe submodules)
 754 execBranchingRepoRecipe vcsDriver (BranchingRepoRecipe taggedCommits) =
 755   mapM_
 756     ( either
 757         (execTaggdCommits vcsDriver)
 758         (execBranchCommits vcsDriver)
 759     )
 760     taggedCommits
 761
 762 execBranchCommits :: CreateRepoAction (BranchCommits submodules)
 763 execBranchCommits
 764   vcsDriver@VCSTestDriver{vcsSwitchBranch}
 765   (BranchCommits branch commits) = do
 766     mapM_ (execCommit vcsDriver) commits
 767     -- add commits and then switch branch
 768     State.modify (switchBranch branch)
 769     state <- State.get -- repo state after the commits and branch switch
 770     liftIO $ vcsSwitchBranch state branch
 771
 772 -- It may seem odd that we add commits on the existing branch and then
 773 -- switch branch. In part this is because git cannot branch from an empty
 774 -- repo state, it complains that the master branch doesn't exist yet.
 775
 776 execTaggdCommits :: CreateRepoAction (TaggedCommits submodules)
 777 execTaggdCommits
 778   vcsDriver@VCSTestDriver{vcsTagState}
 779   (TaggedCommits tagname commits) = do
 780     mapM_ (execCommit vcsDriver) commits
 781     -- add commits then tag
 782     state <- State.get -- repo state after the commits
 783     liftIO $ vcsTagState state tagname
 784     State.modify (addTagOrCommit tagname)
 785
 786 execCommit :: CreateRepoAction (Commit submodules)
 787 execCommit vcsDriver@VCSTestDriver{..} (Commit fileUpdates) = do
 788   mapM_ (either (execFileUpdate vcsDriver) (execSubmoduleAdd vcsDriver)) fileUpdates
 789   state <- State.get -- existing state, not updated
 790   mcommit <- liftIO $ vcsCommitChanges state
 791   State.modify (maybe id addTagOrCommit mcommit)
 792
 793 execFileUpdate :: CreateRepoAction FileUpdate
 794 execFileUpdate VCSTestDriver{..} (FileUpdate filename content) = do
 795   isDir <- liftIO $ doesDirectoryExist (vcsRepoRoot </> filename)
 796   liftIO . when isDir $ removeDirectoryRecursive (vcsRepoRoot </> filename)
 797   liftIO $ writeFile (vcsRepoRoot </> filename) content
 798   state <- State.get -- existing state, not updated
 799   liftIO $ vcsAddFile state filename
 800   State.modify (updateFile filename content)
 801
 802 execSubmoduleAdd :: CreateRepoAction SubmoduleAdd
 803 execSubmoduleAdd vcsDriver (SubmoduleAdd submodulePath source submoduleCommit) = do
 804   submoduleVcsDriver <- liftIO $ vcsSubmoduleDriver vcsDriver source
 805   let submoduleRecipe = WithoutBranchingSupport $ NonBranchingRepoRecipe [TaggedCommits "submodule-tag" [submoduleCommit]]
 806   submoduleState <- liftIO $ createRepo submoduleVcsDriver submoduleRecipe
 807   mainState <- State.get -- existing state, not updated
 808   liftIO $ vcsAddSubmodule vcsDriver mainState (vcsRepoRoot submoduleVcsDriver) submodulePath
 809   State.modify $ addSubmodule submodulePath submoduleState
 810
 811 -- ------------------------------------------------------------
 812
 813 -- * VCSTestDriver for various VCSs
 814
 815 -- ------------------------------------------------------------
 816
 817 -- | Extends 'VCS' with extra methods to construct a repository. Used by
 818 -- 'createRepo'.
 819 --
 820 -- Several of the methods are allowed to rely on the current 'RepoState'
 821 -- because some VCSs need different commands for initial vs later actions
 822 -- (like adding a file to the tracked set, or creating a new branch).
 823 --
 824 -- The driver instance knows the particular repo directory.
 825 data VCSTestDriver = VCSTestDriver
 826   { vcsVCS :: VCS ConfiguredProgram
 827   , vcsRepoRoot :: FilePath
 828   , vcsIgnoreFiles :: Set FilePath
 829   , vcsInit :: IO ()
 830   , vcsAddFile :: RepoState -> FilePath -> IO ()
 831   , vcsSubmoduleDriver :: FilePath -> IO VCSTestDriver
 832   , vcsAddSubmodule :: RepoState -> FilePath -> FilePath -> IO ()
 833   , vcsCommitChanges :: RepoState -> IO (Maybe CommitId)
 834   , vcsTagState :: RepoState -> TagName -> IO ()
 835   , vcsSwitchBranch :: RepoState -> BranchName -> IO ()
 836   , vcsCheckoutTag
 837       :: Either
 838           (TagName -> IO ())
 839           (TagName -> FilePath -> IO ())
 840   }
 841
 842 vcsTestDriverGit
 843   :: Verbosity
 844   -> VCS ConfiguredProgram
 845   -> FilePath
 846   -> FilePath
 847   -> VCSTestDriver
 848 vcsTestDriverGit verbosity vcs submoduleDir repoRoot =
 849   VCSTestDriver
 850     { vcsVCS = vcs'
 851     , vcsRepoRoot = repoRoot
 852     , vcsIgnoreFiles = Set.empty
 853     , vcsInit =
 854         git $ ["init"] ++ verboseArg
 855     , vcsAddFile = \_ filename ->
 856         git ["add", filename]
 857     , vcsCommitChanges = \_state -> do
 858         git $
 859           [ "-c"
 860           , "user.name=A"
 861           , "-c"
 862           , "user.email=a@example.com"
 863           , "commit"
 864           , "--all"
 865           , "--message=a patch"
 866           , "--author=A <a@example.com>"
 867           ]
 868             ++ verboseArg
 869         commit <- git' ["log", "--format=%H", "-1"]
 870         let commit' = takeWhile (not . isSpace) commit
 871         return (Just commit')
 872     , vcsTagState = \_ tagname ->
 873         git ["tag", "--force", "--no-sign", tagname]
 874     , vcsSubmoduleDriver =
 875         pure . vcsTestDriverGit verbosity vcs' submoduleDir . (submoduleDir </>)
 876     , vcsAddSubmodule = \_ source dest -> do
 877         destExists <-
 878           (||)
 879             <$> doesFileExist (repoRoot </> dest)
 880             <*> doesDirectoryExist (repoRoot </> dest)
 881         when destExists $ git ["rm", "-f", dest]
 882         -- If there is an old submodule git dir with the same name, remove it.
 883         -- It most likely has a different URL and `git submodule add` will fai.
 884         submoduleGitDirExists <- doesDirectoryExist $ submoduleGitDir dest
 885         when submoduleGitDirExists $ removeDirectoryRecursive (submoduleGitDir dest)
 886         git ["submodule", "add", source, dest]
 887         git ["submodule", "update", "--init", "--recursive", "--force"]
 888     , vcsSwitchBranch = \RepoState{allBranches} branchname -> do
 889         deinitAndRemoveCachedSubmodules
 890         unless (branchname `Map.member` allBranches) $
 891           git ["branch", branchname]
 892         git $ ["checkout", branchname] ++ verboseArg
 893         updateSubmodulesAndCleanup
 894     , vcsCheckoutTag = Left $ \tagname -> do
 895         deinitAndRemoveCachedSubmodules
 896         git $ ["checkout", "--detach", "--force", tagname] ++ verboseArg
 897         updateSubmodulesAndCleanup
 898     }
 899   where
 900     -- Git 2.38.1 and newer fails to clone from local paths with `fatal: transport 'file'
 901     -- not allowed` unless `protocol.file.allow=always` is set.
 902     --
 903     -- This is not safe in general, but it's fine in the test suite.
 904     --
 905     -- See: https://github.blog/open-source/git/git-security-vulnerabilities-announced/#fn-67904-1
 906     -- See: https://git-scm.com/docs/git-config#Documentation/git-config.txt-protocolallow
 907     vcs' =
 908       vcs
 909         { vcsProgram =
 910             (vcsProgram vcs)
 911               { programDefaultArgs =
 912                   programDefaultArgs (vcsProgram vcs)
 913                     ++ [ "-c"
 914                        , "protocol.file.allow=always"
 915                        ]
 916               }
 917         }
 918     gitInvocation args =
 919       (programInvocation (vcsProgram vcs') args)
 920         { progInvokeCwd = Just repoRoot
 921         }
 922     git = runProgramInvocation verbosity . gitInvocation
 923     git' = getProgramInvocationOutput verbosity . gitInvocation
 924     verboseArg = ["--quiet" | verbosity < Verbosity.normal]
 925     submoduleGitDir path = repoRoot </> ".git" </> "modules" </> path
 926     deinitAndRemoveCachedSubmodules = do
 927       git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg
 928       let gitModulesDir = repoRoot </> ".git" </> "modules"
 929       gitModulesExists <- doesDirectoryExist gitModulesDir
 930       when gitModulesExists $ removeDirectoryRecursive gitModulesDir
 931     updateSubmodulesAndCleanup = do
 932       git $ ["submodule", "sync", "--recursive"] ++ verboseArg
 933       git $ ["submodule", "update", "--init", "--recursive", "--force"] ++ verboseArg
 934       git $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"]
 935       git $ ["clean", "-ffxdq"] ++ verboseArg
 936
 937 type MTimeChange = Int
 938
 939 vcsTestDriverDarcs
 940   :: MTimeChange
 941   -> Verbosity
 942   -> VCS ConfiguredProgram
 943   -> FilePath
 944   -> FilePath
 945   -> VCSTestDriver
 946 vcsTestDriverDarcs mtimeChange verbosity vcs _ repoRoot =
 947   VCSTestDriver
 948     { vcsVCS = vcs
 949     , vcsRepoRoot = repoRoot
 950     , vcsIgnoreFiles = Set.singleton "_darcs"
 951     , vcsInit =
 952         darcs ["initialize"]
 953     , vcsAddFile = \state filename -> do
 954         threadDelay mtimeChange
 955         unless (filename `Map.member` currentWorking state) $
 956           darcs ["add", filename]
 957     , -- Darcs's file change tracking relies on mtime changes,
 958       -- so we have to be careful with doing stuff too quickly:
 959
 960       vcsSubmoduleDriver = \_ ->
 961         fail "vcsSubmoduleDriver: darcs does not support submodules"
 962     , vcsAddSubmodule = \_ _ _ ->
 963         fail "vcsAddSubmodule: darcs does not support submodules"
 964     , vcsCommitChanges = \_state -> do
 965         threadDelay mtimeChange
 966         darcs ["record", "--all", "--author=author", "--name=a patch"]
 967         return Nothing
 968     , vcsTagState = \_ tagname ->
 969         darcs ["tag", "--author=author", tagname]
 970     , vcsSwitchBranch = \_ _ ->
 971         fail "vcsSwitchBranch: darcs does not support branches within a repo"
 972     , vcsCheckoutTag = Right $ \tagname dest ->
 973         darcs ["clone", "--lazy", "--tag=^" ++ tagname ++ "$", ".", dest]
 974     }
 975   where
 976     darcsInvocation args =
 977       (programInvocation (vcsProgram vcs) args)
 978         { progInvokeCwd = Just repoRoot
 979         }
 980     darcs = runProgramInvocation verbosity . darcsInvocation
 981
 982 vcsTestDriverPijul
 983   :: Verbosity
 984   -> VCS ConfiguredProgram
 985   -> FilePath
 986   -> FilePath
 987   -> VCSTestDriver
 988 vcsTestDriverPijul verbosity vcs _ repoRoot =
 989   VCSTestDriver
 990     { vcsVCS = vcs
 991     , vcsRepoRoot = repoRoot
 992     , vcsIgnoreFiles = Set.empty
 993     , vcsInit =
 994         pijul $ ["init"]
 995     , vcsAddFile = \_ filename ->
 996         pijul ["add", filename]
 997     , vcsSubmoduleDriver = \_ ->
 998         fail "vcsSubmoduleDriver: pijul does not support submodules"
 999     , vcsAddSubmodule = \_ _ _ ->
1000         fail "vcsAddSubmodule: pijul does not support submodules"
1001     , vcsCommitChanges = \_state -> do
1002         pijul $
1003           [ "record"
1004           , "-a"
1005           , "-m 'a patch'"
1006           , "-A 'A <a@example.com>'"
1007           ]
1008         commit <- pijul' ["log"]
1009         let commit' = takeWhile (not . isSpace) commit
1010         return (Just commit')
1011     , -- tags work differently in pijul...
1012       -- so this is wrong
1013       vcsTagState = \_ tagname ->
1014         pijul ["tag", tagname]
1015     , vcsSwitchBranch = \_ branchname -> do
1016         --        unless (branchname `Map.member` allBranches) $
1017         --          pijul ["from-branch", branchname]
1018         pijul $ ["checkout", branchname]
1019     , vcsCheckoutTag = Left $ \tagname ->
1020         pijul $ ["checkout", tagname]
1021     }
1022   where
1023     gitInvocation args =
1024       (programInvocation (vcsProgram vcs) args)
1025         { progInvokeCwd = Just repoRoot
1026         }
1027     pijul = runProgramInvocation verbosity . gitInvocation
1028     pijul' = getProgramInvocationOutput verbosity . gitInvocation
1029
1030 vcsTestDriverHg
1031   :: Verbosity
1032   -> VCS ConfiguredProgram
1033   -> FilePath
1034   -> FilePath
1035   -> VCSTestDriver
1036 vcsTestDriverHg verbosity vcs _ repoRoot =
1037   VCSTestDriver
1038     { vcsVCS = vcs
1039     , vcsRepoRoot = repoRoot
1040     , vcsIgnoreFiles = Set.empty
1041     , vcsInit =
1042         hg $ ["init"] ++ verboseArg
1043     , vcsAddFile = \_ filename ->
1044         hg ["add", filename]
1045     , vcsSubmoduleDriver = \_ ->
1046         fail "vcsSubmoduleDriver: hg submodules not supported"
1047     , vcsAddSubmodule = \_ _ _ ->
1048         fail "vcsAddSubmodule: hg submodules not supported"
1049     , vcsCommitChanges = \_state -> do
1050         hg $
1051           [ "--user='A <a@example.com>'"
1052           , "commit"
1053           , "--message=a patch"
1054           ]
1055             ++ verboseArg
1056         commit <- hg' ["log", "--template='{node}\\n' -l1"]
1057         let commit' = takeWhile (not . isSpace) commit
1058         return (Just commit')
1059     , vcsTagState = \_ tagname ->
1060         hg ["tag", "--force", tagname]
1061     , vcsSwitchBranch = \RepoState{allBranches} branchname -> do
1062         unless (branchname `Map.member` allBranches) $
1063           hg ["branch", branchname]
1064         hg $ ["checkout", branchname] ++ verboseArg
1065     , vcsCheckoutTag = Left $ \tagname ->
1066         hg $ ["checkout", "--rev", tagname] ++ verboseArg
1067     }
1068   where
1069     hgInvocation args =
1070       (programInvocation (vcsProgram vcs) args)
1071         { progInvokeCwd = Just repoRoot
1072         }
1073     hg = runProgramInvocation verbosity . hgInvocation
1074     hg' = getProgramInvocationOutput verbosity . hgInvocation
1075     verboseArg = ["--quiet" | verbosity < Verbosity.normal]