Auction.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Module, containing spec to test auction.tz contract.
--
-- This spec is an example of using testing capabilities of morley.
module Test.Interpreter.Auction
  ( test_Auction
  ) where

import Hedgehog (MonadTest, annotate, forAll, property, withTests, (===))
import qualified Hedgehog.Gen as Gen
import Test.Hspec.Expectations (shouldSatisfy)
import Test.Tasty (TestTree)
import Test.Tasty.Hedgehog (testProperty)
import Test.Tasty.HUnit (testCase)

import Michelson.Interpret (ContractEnv(..))
import Michelson.Test
  (ContractPropValidator, contractProp, midTimestamp, testTreesWithTypedContract)
import Michelson.Test.Dummy
import Michelson.Test.Gen (genMutez, genTimestamp)
import Michelson.Test.Util (eitherIsLeft, failedTest, runGen)
import Michelson.Typed (Operation'(..), ToT, TransferTokens(..))
import qualified Michelson.Typed as T
import Tezos.Address (Address(..))
import Tezos.Core (Mutez, Timestamp, timestampPlusSeconds, unMutez, unsafeMkMutez, unsafeSubMutez)
import Tezos.Crypto (KeyHash, genKeyHash)

import Test.Util.Contracts

type Storage = (Timestamp, (Mutez, KeyHash))
type Param = KeyHash

-- | Spec to test auction.tz contract.
--
-- This test serves as an example on how to test contract with both unit tests
-- and Hedgehog.
test_Auction :: IO [TestTree]
test_Auction =
  testTreesWithTypedContract (inContractsDir "tezos_examples/attic/auction.tz") auctionTest
  where
    -- Test auction.tz, everything should be fine
    auctionTest contract =
      pure
      [ testCase "Bid after end of auction triggers failure" $
          contractProp contract
            (flip shouldSatisfy (isLeft . fst))
            (env { ceAmount = unsafeMkMutez 1200 })
            keyHash2
            (aBitBeforeMidTimestamp, (unsafeMkMutez 1000, keyHash1))

      , testProperty "Random check (sparse distribution)" $ withTests 200 $
          hhProp contract genTimestamp genMutez

      , testProperty "Random check (dense end of auction)" $
          hhProp contract denseTime genMutez

      , testProperty "Random check (dense amount)" $
          hhProp contract genTimestamp denseAmount
      ]

    hhProp contract eoaGen amountGen =
      property $ do
        eoa <- forAll eoaGen
        amount <- forAll amountGen
        keyHash <- forAll genKeyHash
        param <- forAll genKeyHash

        let storage = (eoa, (amount, keyHash))
        let validate = validateAuction env param storage
        contractProp contract validate env param storage

    aBitBeforeMidTimestamp = midTimestamp `timestampPlusSeconds` -1
    -- ^ 1s before NOW

    denseTime = timestampPlusSeconds midTimestamp <$> Gen.enum -4 4
    denseAmount = unsafeMkMutez . (midAmount +) . fromInteger <$> Gen.enum -4 4

    env = dummyContractEnv
            { ceNow = midTimestamp
            , ceAmount = unsafeMkMutez midAmount
            }
    midAmount = unMutez (maxBound `unsafeSubMutez` minBound) `div` 2

keyHash1 :: KeyHash
keyHash1 = runGen 20 300406 genKeyHash

keyHash2 :: KeyHash
keyHash2 = runGen 20 142917 genKeyHash

-- | This validator checks the result of auction.tz execution.
--
-- It checks following properties:
--
-- * Current timestamp is before end of auction
-- * Amount of new bid is higher than previous one
--
-- In case of successful execution:
--
-- * End of auction timestamp in updated storage is unchanged
-- * Amount in updated storage is equal to @AMOUNT@ of transaction
-- * Key hash in updated storage is equal to contract's parameter
-- * Script returned exactly one operation, @TransferTokens@, which
--   returns money back to the previous bidder
validateAuction
  :: MonadTest m
  => ContractEnv
  -> Param
  -> Storage
  -> ContractPropValidator (ToT Storage) (m ())
validateAuction env newKeyHash (endOfAuction, (amount, keyHash)) (resE, _)
  | ceNow env > endOfAuction
      = annotate "Failure didn't trigger on end of auction" >> eitherIsLeft resE
  | ceAmount env <= amount
      = annotate ("Failure didn't trigger on attempt to bid"
                  <> " with amount <= than previous bid") >> eitherIsLeft resE
  | Left e <- resE
      = failedTest $ "Unexpected script fail: " <> show e

  | Right (_, (T.VPair ( T.VTimestamp endOfAuction', _))) <- resE
  , endOfAuction /= endOfAuction'
      = failedTest "End of auction timestamp of contract changed"

  | Right (_, (T.VPair (_, T.VPair (T.VMutez amount', _)))) <- resE
  , amount' /= ceAmount env
      = failedTest $ "Storage updated to wrong value: new amount"
                      <> " is not equal to amount of transaction"
  | Right (_, (T.VPair (_, T.VPair (_, T.VKeyHash keyHash')))) <- resE
  , keyHash' /= newKeyHash
      = failedTest $ "Storage updated to wrong value: new key hash"
                      <> " is not equal to contract's parameter"

  | Right (ops, _) <- resE
     = let annotate' msg =
              annotate $ "Invalid money back operation (" <> msg <> ")"
        in case ops of
            [OpTransferTokens (TransferTokens T.VUnit retAmount (T.VContract retAddr _))] -> do
              annotate' "wrong amount" >> retAmount === amount
              annotate' "wrong address" >> KeyAddress keyHash === retAddr
            _ -> failedTest $ "Unexpected operation list: " <> show ops