diff --git a/test/repo/Main.hs b/test/repo/Main.hs index 131b12bb5f71033f5f6fcc9b6b275cebfd020a89..14e35b1f7215729fffa5aa99dcde6a410435e7ab 100644 --- a/test/repo/Main.hs +++ b/test/repo/Main.hs @@ -2,23 +2,30 @@ module Main where -import Control.Applicative -import Control.Monad -import qualified Data.ByteString as B +import Control.Monad (forM) import qualified Data.ByteString.Lazy as L -import Data.Git.Ref -import Data.Git.Repository +import Data.Git.Ref (Ref, SHA1, hashLBS) +import Data.Git.Repository (Git) import Data.Git.Storage + ( Git (gitRepoPath), + findRepoMaybe, + withCurrentRepo, + ) import Data.Git.Storage.Loose -import Data.Git.Storage.Object -import Data.Git.Types -import Data.Maybe -import Monad -import System.Exit -import Test.Tasty -import Test.Tasty.QuickCheck -import Text.Bytedump + ( looseEnumeratePrefixes, + looseEnumerateWithPrefix, + looseMarshall, + looseRead, + looseReadRaw, + looseUnmarshallRaw, + ) +import Data.Git.Storage.Object (ObjectHeader) +import Data.Maybe (catMaybes) +import Monad (testGitMonadLocal) +import System.Exit (exitFailure) +import Text.Bytedump (dumpDiffLBS) +onLocalRepo :: (Git SHA1 -> IO ()) -> IO () onLocalRepo f = do fpath <- findRepoMaybe case fpath of @@ -42,6 +49,7 @@ doLocalMarshallEq git = do then return $ Just (ref, hashed, raw, raw2) else return Nothing +printDiff :: (Show a1, Show a2, Show a3, Show a4) => (a1, a2, (a3, L.ByteString), (a4, L.ByteString)) -> IO () printDiff (actualRef, gotRef, (actualHeader, actualRaw), (gotHeader, gotRaw)) = do putStrLn "=========== difference found" putStrLn ("ref expected: " ++ show actualRef) @@ -51,6 +59,7 @@ printDiff (actualRef, gotRef, (actualHeader, actualRaw), (gotHeader, gotRaw)) = putStrLn "raw diff:" putStrLn $ dumpDiffLBS actualRaw gotRaw +printLocalMarshallError :: (Foldable t, Show a1, Show a2, Show a3, Show a4) => t (a1, a2, (a3, L.ByteString), (a4, L.ByteString)) -> IO () printLocalMarshallError l | null l = putStrLn "local marshall: [OK]" | otherwise = @@ -58,6 +67,7 @@ printLocalMarshallError l >> mapM_ printDiff l >> exitFailure +main :: IO () main = do onLocalRepo $ \(git :: Git SHA1) -> do doLocalMarshallEq git >>= printLocalMarshallError . catMaybes . concat diff --git a/test/repo/Monad.hs b/test/repo/Monad.hs index 02cd2e84db49002e51d61a6ae3e94182d2fe8175..0fc17f9fa4617d9a274823947ee6696f72f7e782 100644 --- a/test/repo/Monad.hs +++ b/test/repo/Monad.hs @@ -5,12 +5,21 @@ module Monad ) where -import Control.Applicative -import Control.Exception -import Control.Monad +import Control.Exception (SomeException, try) +import Control.Monad (when) import Data.Git.Monad + ( GitM, + GitMonad (liftGit), + Person (Person, personEmail, personName, personTime), + RefName, + getAuthor, + setMessage, + withBranch, + withCommit, + withCurrentRepo, + ) import Data.Git.Types (GitTime (..)) -import System.Exit +import System.Exit (exitFailure) import qualified System.Hourglass as T testBranch :: RefName @@ -25,7 +34,7 @@ catchAll f = do Right (Right _) -> putStrLn " test/git/monad [OK]" where catchAll' :: IO a -> IO (Either SomeException a) - catchAll' f = try f + catchAll' = try failWith :: String -> IO () failWith msg = do diff --git a/test/unit/Main.hs b/test/unit/Main.hs index db5e57aac5692058889cb97d9dd2d07d1fba0e5c..52487640a9d1f84c976763988a7d7c1608be23ec 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -1,20 +1,66 @@ {-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main where -import Control.Applicative -import Control.Monad +import Control.Monad (liftM3, replicateM) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Git.Ref + ( HashAlgorithm (..), + Ref, + SHA1, + fromBinary, + fromHex, + toBinary, + toHex, + ) import Data.Git.Revision -import Data.Git.Storage.Loose + ( RevModifier + ( RevModAtDate, + RevModAtType, + RevModParent, + RevModParentFirstN + ), + Revision (..), + fromString, + ) +import Data.Git.Storage.Loose (looseMarshall, looseUnmarshall) import Data.Git.Storage.Object + ( Object, + ObjectType (TypeBlob, TypeCommit, TypeTag, TypeTree), + Objectable (toObject), + ) import Data.Git.Types + ( Blob (Blob), + Commit (Commit), + CommitExtra (CommitExtra), + EntName, + GitTime (GitTime), + ModePerm (..), + Person (Person), + Tag (Tag), + Tree (Tree), + TreeEnt, + entName, + ) import Data.Hourglass -import Data.Maybe -import Test.Tasty + ( Elapsed (..), + Seconds (Seconds), + TimezoneOffset (TimezoneOffset), + ) +import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.QuickCheck + ( Arbitrary (arbitrary), + Gen, + Positive (getPositive), + choose, + elements, + frequency, + oneof, + resize, + testProperty, + ) -- for arbitrary instance to generate only data that are writable -- to disk. i.e. no deltas. @@ -24,16 +70,22 @@ data ObjNoDelta hash = ObjNoDelta (Object hash) instance Show (ObjNoDelta hash) where show (ObjNoDelta o) = show o +arbitraryBS :: Int -> Gen B.ByteString arbitraryBS size = B.pack . map fromIntegral <$> replicateM size (choose (0, 255) :: Gen Int) +arbitraryBSno0 :: Int -> Gen B.ByteString arbitraryBSno0 size = B.pack . map fromIntegral <$> replicateM size (choose (1, 255) :: Gen Int) +arbitraryBSasciiNoSpace :: Int -> Gen B.ByteString arbitraryBSasciiNoSpace size = B.pack . map fromIntegral <$> replicateM size (choose (0x21, 0x7f) :: Gen Int) +arbitraryBSascii :: Int -> Gen B.ByteString arbitraryBSascii size = B.pack . map fromIntegral <$> replicateM size (choose (0x20, 0x7f) :: Gen Int) +arbitraryBSnoangle :: Int -> Gen B.ByteString arbitraryBSnoangle size = B.pack . map fromIntegral <$> replicateM size (choose (0x40, 0x7f) :: Gen Int) +arbitraryEntname :: Int -> Gen EntName arbitraryEntname size = entName . B.pack . map fromIntegral <$> replicateM size range where range :: Gen Int @@ -49,8 +101,10 @@ arbitraryRef alg = fromBinary <$> arbitraryBS (hashDigestSize alg) instance HashAlgorithm hash => Arbitrary (Ref hash) where arbitrary = arbitraryRef (error "alg") +arbitraryMsg :: Gen B.ByteString arbitraryMsg = arbitraryBSno0 1 +arbitraryLazy :: Gen L.ByteString arbitraryLazy = L.fromChunks . (: []) <$> arbitraryBS 40 arbitraryRefList :: Gen [Ref SHA1] @@ -59,6 +113,7 @@ arbitraryRefList = replicateM 2 arbitrary arbitraryEnt :: Gen (TreeEnt SHA1) arbitraryEnt = liftM3 (,,) arbitrary (arbitraryEntname 23) arbitrary +arbitraryEnts :: Gen [TreeEnt SHA1] arbitraryEnts = choose (1, 2) >>= \i -> replicateM i arbitraryEnt instance Arbitrary TimezoneOffset where @@ -83,8 +138,10 @@ instance Arbitrary RevModifier where --, RevModAtN . getPositive <$> arbitrary ] +arbitraryDate :: Gen [Char] arbitraryDate = elements ["yesterday", "29-Jan-1982", "5 days ago"] +arbitraryType :: Gen [Char] arbitraryType = elements ["commit", "tree"] instance Arbitrary Revision where @@ -93,6 +150,7 @@ instance Arbitrary Revision where rms <- choose (1, 4) >>= flip replicateM arbitrary return $ Revision s rms +arbitraryName :: Gen Person arbitraryName = liftM3 Person @@ -100,8 +158,10 @@ arbitraryName = (arbitraryBSnoangle 16) arbitrary +arbitraryObjTypeNoDelta :: Gen ObjectType arbitraryObjTypeNoDelta = oneof [return TypeTree, return TypeBlob, return TypeCommit, return TypeTag] +arbitrarySmallList :: Gen [CommitExtra] arbitrarySmallList = frequency [(2, return []), (1, resize 3 arbitrary)] instance Arbitrary (Commit SHA1) where @@ -138,6 +198,7 @@ prop_object_marshalling_id (ObjNoDelta obj) = | show a == show b = True | otherwise = error ("not equal:\n" ++ show a ++ "\ngot: " ++ show b) +refTests :: [TestTree] refTests = [ testProperty "hexadecimal" (marshEqual (fromHex . toHex :: Ref SHA1 -> Ref SHA1)), testProperty "binary" (marshEqual (fromBinary . toBinary :: Ref SHA1 -> Ref SHA1)), @@ -149,14 +210,16 @@ refTests = | a == b = True | otherwise = error ("expecting: " ++ show a ++ " got: " ++ show b) +objTests :: [TestTree] objTests = [ testProperty "unmarshall.marshall==id" prop_object_marshalling_id ] +main :: IO () main = defaultMain $ testGroup - "hit" + "hgit" [ testGroup "ref marshalling" refTests, testGroup "object marshalling" objTests ]