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

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