miss-0: tests/TestUtil.hs

{-# LANGUAGE ImplicitParams      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module TestUtil
  ( module Test.Tasty
  , module Test.Tasty.HUnit
  , module Test.Tasty.TestVector
  , module Test.Tasty.QuickCheck
  , testContact, testDate, testCommit, testTag
  , notTheEmptyTreeSha
  , testInDir, testPropInDir, testWithRepo, testRepoProp, testBottom
  , expectThrow
  , ascii2bytestring
  , shouldReturn, shouldNotChange
  , shouldSatisfy, shouldNotSatisfy
  -- Special types to help generate property tests.
  , ArbMode(..)
  , ArbDate(..)
  , zeroSha
  ) where

import qualified Control.Monad.Catch as E
import           Control.Monad.IO.Class
import           Data.Bifunctor
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import           Data.Char (ord)
import qualified Data.Map as Map
import           Data.Word
import           System.Directory
import           System.IO.Temp
import           Test.ChasingBottoms (isBottom)
import           Test.Tasty
import           Test.Tasty.HUnit
import           Test.Tasty.TestVector
import           Test.Tasty.QuickCheck
import           Text.Printf

import Data.Git.Formats
import Data.Git.Hash
import Data.Git.Monad
import Data.Git.Object
import Data.Git.Types

zeroSha :: Sha1
zeroSha = fromHex "0000000000000000000000000000000000000000"

instance Arbitrary Sha1 where
  arbitrary = Sha1 . BS.pack <$> vector 20
  -- There are no valid shrinkings for a SHA
  shrink _ = []

instance Arbitrary Sha1Hex where
  arbitrary =
    Sha1Hex . BS.pack <$> vectorOf 40 (elements $ map (fromIntegral.ord) "0123456789abcdef")
  -- There are no valid shrinkings for a SHA
  shrink _ = []

instance Arbitrary BS.ByteString where
  arbitrary = BS.pack <$> arbitrary
  -- Shrink to nothing to see if the ByteString actually mattered for the error.
  -- Further shrinks are probably uninteresting since we don't expect the bytestring
  -- structure to matter.
  shrink _ = [mempty]

instance Arbitrary BL.ByteString where
  arbitrary = BL.pack <$> arbitrary
  -- Shrink to nothing to see if the ByteString actually mattered for the error.
  -- Further shrinks are probably uninteresting since we don't expect the bytestring
  -- structure to matter.
  shrink _ = [mempty]

newtype ArbMode =
    AM { unAM :: Mode }
  deriving (Eq, Ord, Show)

instance Arbitrary ArbMode where
  arbitrary = AM <$> elements [BlobMode, ExecMode, LinkMode]
  -- It is what it is
  shrink _ = []

newtype ArbDate =
    AD { unAD :: Date }
  deriving (Eq, Ord, Show)

instance Arbitrary ArbDate where
  arbitrary = do
    -- Git only seems to handle times since the Unix epoc.
    p <- arbitrary::Gen Word
    z <- elements . map ascii2bytestring $ [ "+0000", "-0500", "-0400", "+0930", "UTC" ]
    return (AD (fromIntegral p, z))

instance Arbitrary SafeString where
  arbitrary =
      frequency
      [ (1, pure "")
      , (20, do
           f <- suchThat arbitrary (`BS.notElem` (ascii2bytestring " .,:;<>\"'"))
           m <- listOf1 (suchThat arbitrary (`BS.notElem` (ascii2bytestring "<>\x0a\x00")))
           l <- suchThat arbitrary (`BS.notElem` (ascii2bytestring " .,:;<>\"'"))
           let b = BS.pack $ f:m++[l]
           maybe (fail $ "SafeString Arbitrary doesn't match definition") pure .
                 safeString $ b)
      ]

instance Arbitrary Contact where
  arbitrary = Contact <$> arbitrary <*> arbitrary

instance Arbitrary Blob where
  arbitrary = Blob <$> arbitrary
  -- A blob is an atomic object
  shrink _ = []

instance Arbitrary PathComponent where
  arbitrary =
    (pathComponent . BS.pack) <$> listOf1 (suchThat arbitrary (`BS.notElem` "\x00/")) >>=
    maybe (fail "PathComponent Arbitrary doesn't match definition") pure

instance Arbitrary LfFree where
  arbitrary =
    (lfFree . BS.pack) <$> listOf1 (suchThat arbitrary (`BS.notElem` "\x0a")) >>=
    maybe (fail "LfFree Arbitrary doesn't match definition") pure

instance Arbitrary TreeEntry where
  arbitrary = Entry <$> arbitrary <*> (unAM <$> arbitrary)

instance Arbitrary Tree where
  arbitrary = (Tree . Map.fromList) <$> listOf arbitrary

instance Arbitrary ObjectType where
  arbitrary = elements [BlobType, TreeType, CommitType, TagType]

instance Arbitrary Tag where
  arbitrary =
    Tag <$> arbitrary  <*> arbitrary <*> arbitrary <*> (second unAD <$> arbitrary) <*> arbitrary

instance Arbitrary Commit where
  arbitrary =
    Commit <$> arbitrary
           <*> listOf arbitrary
           <*> (second unAD <$> arbitrary)
           <*> (second unAD <$> arbitrary)
           <*> arbitrary

instance Arbitrary Object where
  arbitrary = oneof
              [ BlobObj   <$> arbitrary
              , TreeObj   <$> arbitrary
              , CommitObj <$> arbitrary
              , TagObj    <$> arbitrary
              ]

testContact :: Contact
testContact = makeContact "Bob McTesterton" "bob@mctesterton.gov"

testDate :: Date
testDate = (1467644623, "+0000")

testCommit :: Commit
testCommit = Commit { commitTree=emptyTreeSha
                    , commitParents=[]
                    , commitAuthor=(testContact, testDate)
                    , commitCommitter=(testContact, testDate)
                    , commitMessage="msg" }

testTag :: Tag
testTag = Tag emptyTreeSha TreeType "the-tag" (testContact, testDate) "the message"

escapeFileTestName :: String -> String
escapeFileTestName = map (\case {' ' -> '_'; a -> a })

notTheEmptyTreeSha :: Sha1
notTheEmptyTreeSha = sha1 $ Blob "a thing which isn't the empty tree"

expectThrow :: (MonadIO m, E.MonadCatch m) => m () -> m ()
expectThrow act =
    E.catch (act >> liftIO (assertFailure "Didn't throw"))
            (\(_::E.SomeException) -> return ())

-- | Creates a temporary directory, cdsinto it, and runs the test
--   Ifthe tests fails, save and report the directory otherwise cleans up.
testInDir :: TestName -> IO () -> TestTree
testInDir name act =
  testCase name $ getCanonicalTemporaryDirectory >>= \stmpdir -> do
    tdir <- createTempDirectory stmpdir (printf "miss-test-%s" (escapeFileTestName name))
    E.handle (\(e::E.SomeException) -> do
               printf "\nTest working directory saved at %s\n" tdir
               E.throwM e) $
          withCurrentDirectory tdir $ act
    removeDirectoryRecursive tdir

testPropInDir :: (Show a, Arbitrary a, Testable prop) => TestName -> (a -> IO prop) -> TestTree
testPropInDir name prop =
  testProperty name $ \a -> ioProperty $ getCanonicalTemporaryDirectory >>= \stmpdir -> do
    tdir <- createTempDirectory stmpdir (printf "miss-test-%s" (escapeFileTestName name))
    r <- E.handle (\(e::E.SomeException) -> do
               printf "\nTest working directory saved at %s\n" tdir
               E.throwM e) $
          withCurrentDirectory tdir $ prop a
    removeDirectoryRecursive tdir
    return r

testRepoProp :: (Show a, Arbitrary a, Testable prop) => TestName -> (a -> Git prop) -> TestTree
testRepoProp name prop = testPropInDir name (\a -> initRepo Nothing >> runGit ".git" (prop a))

-- | Test that something did fail when it should
testBottom :: TestName -> a -> TestTree
testBottom name = testCase name . assertBool "Not bottom!" . isBottom


-- | Create a test repository in a temp directory rooted at the given path, run the given action,
--   and then delete the repository if no exception is thrown.
testWithRepo :: TestName -> Git () -> TestTree
testWithRepo name git = testInDir name (initRepo Nothing >> runGit ".git" git)

ascii2word8 :: String -> [Word8]
ascii2word8 = map (fromIntegral.ord)

ascii2bytestring :: String -> BS.ByteString
ascii2bytestring = BS.pack . ascii2word8

infix 1 `shouldReturn`, `shouldNotChange`, `shouldSatisfy`, `shouldNotSatisfy`

-- |
-- @action \`shouldReturn\` expected@ sets the expectation that @action@
-- returns @expected@.
shouldReturn :: (HasCallStack, Show a, Eq a, MonadIO m) => m a -> a -> m ()
action `shouldReturn` expected = action >>= liftIO . (@?= expected)

shouldNotChange :: (HasCallStack, Eq a, Show a, MonadIO m) => (a -> m a) -> a -> m ()
shouldNotChange f a = f a `shouldReturn` a

-- |
-- @v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@.
shouldSatisfy :: (HasCallStack, Show a, MonadIO m) => a -> (a -> Bool) -> m ()
shouldSatisfy v p = liftIO $ (p v) @?= True

-- |
-- @v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@.
shouldNotSatisfy :: (HasCallStack, Show a, MonadIO m) => a -> (a -> Bool) -> m ()
shouldNotSatisfy v p = liftIO $ (p v) @?= False