miss-0: tests/Tests/Git.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Tests.Git (tests) where

import           Control.Monad
import           Control.Monad.Trans
import qualified Data.ByteString.Lazy as BL
import           Data.Git.Formats
import           Data.Git.Hash
import           Data.Git.Monad
import           Data.Git.Object
import           Data.Git.Ref
import           Data.Git.Types
import qualified Data.Map as Map
import           Data.Maybe (listToMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           System.Process
import           System.Exit
import           Test.QuickCheck.Gen (unGen)
import           Test.QuickCheck.Random (mkQCGen)
import           TestUtil
import           Text.Printf

tests :: TestTree
tests = testGroup "Git"
  [ gitTests
  , packingTests
  ]

gitTests :: TestTree
gitTests = testGroup "GitT"
  [ testRepoProp "read-write Blob" $ \b -> do
      s <- writeBlob b
      flushObjects
      (Just b == ) <$> findBlob s
  , testRepoProp "read-write Tree" $ \t -> do
      s <- writeTree t
      (Just t == ) <$> findTree s
  , testRepoProp "read-write Commit" $ \c -> do
      s <- writeCommit c
      (Just c == ) <$> findCommit s
  , testRepoProp "read-write Tagt" $ \t -> do
      s <- writeTag t
      (Just t == ) <$> findTag s
  , testRepoProp "resolveSha" $ \b -> do
      bs <- writeBlob b
      let Just fn = pathComponent "file"
      ts <- writeTree . Tree . Map.fromList $ [(Entry fn BlobMode, bs)]
      (Just bs == ) <$> resolveSha ts [fn]
  , testRepoProp "resolveBlob" $ \b -> do
      bs <- writeBlob b
      let Just fn = pathComponent "file"
      ts <- writeTree . Tree . Map.fromList $ [(Entry fn BlobMode, bs)]
      (Just b == ) <$> resolveBlob ts [fn]
  , testWithRepo "resolveSha" $ do
      bs <- writeBlob (Blob "saf234fdf")
      let fn = "file"
      sts <- writeTree (Tree (Map.fromList [(Entry fn BlobMode, bs)]))
      let dn = "dir"
      ts <- writeTree (Tree (Map.fromList [(Entry dn TreeMode, sts)]))
      cs <- writeCommit $ testCommit { commitTree = ts }
      gs <- writeTag (Tag cs CommitType "Our Tag" (testContact, testDate) "No Message")
      resolveSha ts [] >>= liftIO . (@=?) (Just ts)
      resolveSha cs [] >>= liftIO . (@=?) (Just ts)
      resolveSha zeroSha [] >>= liftIO . (@=?) Nothing
      resolveSha cs [dn] >>= liftIO . (@=?) (Just sts)
      resolveSha cs [dn, fn] >>= liftIO . (@=?) (Just bs)
      resolveSha gs [] >>= liftIO . (@=?) (Just ts)
      resolveSha gs [dn] >>= liftIO . (@=?) (Just sts)
      resolveSha gs [dn, fn] >>= liftIO . (@=?) (Just bs)
  , testWithRepo "grepCommit" $ do
      (cs'::[Commit]) <- liftIO $ generate $ listOf1 arbitrary
      let cs = foldl (\pl c -> (c {commitParents=maybe [] (pure.sha1) $ listToMaybe pl}):pl) [] cs'
      tc <- head <$> mapM writeCommit cs
      forM_ cs $ \c ->
        grepCommit ((==) (commitTree c) . commitTree) tc >>= liftIO . (@=?) (Just $ sha1 c)
      grepCommit (const False) tc >>= liftIO . (@=?) Nothing
      grepCommit (const True) zeroSha >>=
                 liftIO . (@=?) Nothing
  , testWithRepo "Test packed ref reading" $ do
      c1 <- writeCommit $ testCommit
      c2 <- writeCommit $ testCommit { commitParents = [c1] }
      writeBranch "master" c1
      liftIO $ callProcess "git" ["pack-refs", "--all"]
      readBranch "master" >>= liftIO . (@=?) (Just c1)
      writeBranch "master" c2
      lookupRef (Branch "master") >>= liftIO . (@=?) (Just c2)
  ]

packingTests :: TestTree
packingTests = testGroup "PackingT"
  [ testRepoProp "packed read-write Blob" $ \b -> do
      s <- packing $ do
            s' <- writeBlob b
            flushObjects
            return s'
      (Just b == ) <$> findBlob s
  , testRepoProp "packed read-write Tree" $ \t -> do
      s <- packing $ writeTree t
      (Just t == ) <$> findTree s
  , testRepoProp "packed read-write Commit" $ \c -> do
      s <- packing $ writeCommit c
      (Just c == ) <$> findCommit s
  , testRepoProp "read-write Tagt" $ \t -> do
      s <- packing $ writeTag t
      (Just t == ) <$> findTag s
  , testRepoProp "packed resolveSha" $ \b -> do
      let Just fn = pathComponent "file"
      (bs, ts) <- packing $ do
        bs' <- writeBlob b
        ts' <- writeTree . Tree . Map.fromList $ [(Entry fn BlobMode, bs')]
        return (bs', ts')
      (Just bs == ) <$> resolveSha ts [fn]
  , testRepoProp "packed finds after sync" $ \b -> do
      let Just fn = pathComponent "file"
      packing $ do
        bs' <- writeBlob b
        ts' <- writeTree . Tree . Map.fromList $ [(Entry fn BlobMode, bs')]
        flushObjects
        (Just bs' == ) <$> resolveSha ts' [fn]
  , testInDir "Repacked" $ do
      os <- generate $ listOf1 arbitrary
      initRepo Nothing
      void . runGit ".git" $ mapM writeObject os
      rawSystem "git" ["repack", "-a", "-k", "-d", "-q"] >>= liftIO . (@=?) ExitSuccess
      runGit ".git" $
        forM_ os $ \o ->
          lookupSha (sha1 o) >>= liftIO . (@=?) (Just o)
  , testInDir "Delta" $ do
      let gen = mkQCGen 27
      let foo = unGen (BL.pack <$> vectorOf 2000 arbitrary) gen 569
      let bar = unGen (BL.pack <$> vectorOf  150 arbitrary) gen 457
      let baz = unGen (BL.pack <$> vectorOf  100 arbitrary) gen 727
      let f1 = Blob $ mconcat [BL.take 2000 foo, " base "]
      let f2 = Blob $ mconcat [BL.take 1800 foo, " delta1 ", bar]
      let f3 = Blob $ mconcat [BL.take 1800 foo, " delta delta2 ", baz]
      initRepo Nothing
      (s1, s2, s3) <- runGit ".git" $ (,,) <$> writeBlob f1 <*> writeBlob f2 <*> writeBlob f3
      let [h1, h2, h3] = map (T.unpack.TE.decodeUtf8.getSha1Hex.toHex) [s1, s2, s3]
      void $ readProcess "git"  ["pack-objects", ".git/objects/pack/pack"]
               (printf "%s\n%s\n%s\n" h1 h2 h3)
      -- Loose objects are prefered so they have to go.
      system "rm .git/objects/??/* && rmdir .git/objects/??" >>= liftIO . (@=?) ExitSuccess
      runGit ".git" $
        forM_ [f1, f2, f3] $ \o ->
          lookupSha (sha1 o) >>= liftIO . (@=?) (Just $ BlobObj o)
  ]