Auction.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | 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 (forAll, property, withTests)
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Test.Tasty (TestTree)
import Test.Tasty.Hedgehog (testProperty)

import Hedgehog.Gen.Tezos.Core (genMutez', genTimestamp, midTimestamp)
import Hedgehog.Gen.Tezos.Crypto (genKeyHash)
import Morley.Tezos.Address (Address(..))
import Morley.Tezos.Core (Mutez, Timestamp, timestampPlusSeconds)
import Morley.Tezos.Crypto (KeyHash, hashKey)
import Test.Cleveland
import Test.Cleveland.Lorentz.Import (embedContract)
import Test.Cleveland.Util (runGen)

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 :: [TestTree]
test_Auction =
  [ testScenarioOnEmulator "Bid after end of auction triggers failure" $ withInitialNow midTimestamp
    $ scenario do
      let initState = (aBitBeforeMidTimestamp, (1000, keyHash1))
      handle <- originateSimple @Param @Storage "auction" initState contract
      transfer TransferData
        { tdTo = handle
        , tdAmount = 1200
        , tdEntrypoint = DefEpName
        , tdParameter = keyHash2 }
        & expectFailedWith ()

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

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

  , testProperty "Random check (dense amount)" $
      hhProp genTimestamp denseAmount
  ]
  where
    contract =
      $$(embedContract @Param @Storage @() (inContractsDir "tezos_examples/attic/auction.tz"))

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

        testScenarioProps $ withInitialNow midTimestamp $ scenario do
          addr <- newFreshAddress auto
          pk <- getPublicKey addr
          let storage = (eoa, (amount, keyHash))
              keyHash = hashKey pk
          handle <- originate OriginateData
            { odName = "auction"
            , odStorage = storage
            , odContract = contract
            , odBalance = amount
            }
          resE <- attempt do
            transfer TransferData
              { tdTo = handle
              , tdAmount = midAmount
              , tdEntrypoint = DefEpName
              , tdParameter = param }
            getStorage handle
          validateAuction midTimestamp midAmount addr param storage resE

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

    denseTime = timestampPlusSeconds midTimestamp <$> Gen.enum -4 4
    denseAmount = genMutez' $ Range.constant (midAmount - 4) (midAmount + 4)
    midAmount = maxMutez `div` 2
    genMutez'' = genMutez' $ Range.constant 0 maxMutez
    maxMutez = maxBound `div` 100

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
  :: MonadCleveland caps m
  => Timestamp
  -> Mutez
  -> Address
  -> Param
  -> Storage
  -> Either SomeException Storage
  -> m ()
validateAuction ceNow ceAmount addr newKeyHash (endOfAuction, (amount, _)) resE
  | ceNow > endOfAuction
  = assert (isLeft resE) "Failure didn't trigger on end of auction"
  | ceAmount <= amount
  = assert (isLeft resE)
      "Failure didn't trigger on attempt to bid with amount <= than previous bid"
  | Left e <- resE
      = failure $ "Unexpected script fail: " <> fromString (displayException e)

  | Right (endOfAuction', _) <- resE
  , endOfAuction /= endOfAuction'
      = failure "End of auction timestamp of contract changed"

  | Right (_, (amount', _)) <- resE
  , amount' /= ceAmount
      = failure $ "Storage updated to wrong value: new amount"
                      <> " is not equal to amount of transaction"
  | Right (_, (_, keyHash')) <- resE
  , keyHash' /= newKeyHash
      = failure $ "Storage updated to wrong value: new key hash"
                      <> " is not equal to contract's parameter"
  | Right _ <- resE
     = getBalance addr @@== amount