TransferCheck.hs

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

module TestSuite.Cleveland.TransferCheck
  ( test_TransferFromContract
  , test_nonUnitParamToImplicitAccount_fails
  ) where

import Test.Tasty (TestTree, testGroup)

import Lorentz ((#))
import Lorentz qualified as L
import Lorentz.Value
import Morley.Util.Named ((!))
import Test.Cleveland
import TestSuite.Util (idContract, shouldFailWithMessage)

test_TransferFromContract :: TestTree
test_TransferFromContract = testGroup "Transfers from contract"
  [ testScenarioOnEmulator "Forbid transfers to implicit accounts (#440)" $ scenarioEmulated do
      testRevealContract morleyMessage
  , testScenarioOnNetwork "Forbid transfers to implicit accounts (#440)" $ scenario do
      testRevealContract rpcMessage

  , testScenarioOnEmulator "Forbid transfers to empty implicit accounts (#440)" $ scenario do
      testEmptyImplicitAccount morleyMessage
  , testScenarioOnNetwork "Forbid transfers to empty implicit accounts (#440)" $ scenario do
      testEmptyImplicitAccount rpcMessage
  , testScenario "Fails transfering 0tz to plain account" $ scenario
      $ testZeroTransactionFails
  , testScenario "Success transfering 0tz to a contract" $ scenario
      $ testZeroTransactionSuccess
  , testScenario "Allow transferring 0ꜩ from TRANSFER_TOKENS (#440)" $ scenario testEmptyTransfer
  ]
  where
    morleyMessage :: String
    morleyMessage = "Global transaction of funds (200 μꜩ) from an originated contract"

    rpcMessage :: String
    rpcMessage = "Contracts (rx) cannot be revealed"

    testRevealContract :: MonadCleveland caps m => String -> m ()
    testRevealContract expectedErrorMsg = do
      addr <- newAddress auto
      contractAddr <- originateSimple @() @() "rx" () idContract

      comment "give some funds to the originated contract"
      transferMoney contractAddr 200

      comment "fail when transferring from contract"
      transferMoney addr 200
        & withSender (toAddress contractAddr)
        & shouldFailWithMessage expectedErrorMsg

    testEmptyImplicitAccount :: MonadCleveland caps m => String -> m ()
    testEmptyImplicitAccount expectedErrorMsg = do
      testAddr <- newFreshAddress auto
      contractAddr <- originate OriginateData
        { odName = "rx"
        , odStorage = ()
        , odBalance = 500
        , odContract = idContract @() @()
        }

      comment "fail when transferring from contract"
      transferMoney testAddr 200
        & withSender (toAddress contractAddr)
        & shouldFailWithMessage expectedErrorMsg

    testEmptyTransfer :: MonadCleveland caps m => m ()
    testEmptyTransfer = do
      addr1 <- originateSimple "test1" () zeroTransferContract
      addr2 <- originateSimple "test2" () idContract
      call addr1 L.CallDefault (toTAddress addr2)

zeroTransferContract :: L.Contract (L.TAddress () ()) () ()
zeroTransferContract = L.defaultContract $
  L.car #
  L.pairE
    ( L.transferTokensE
        ! #contract do
           L.contract # L.assertSome [L.mt|Invalid contract address|]
        ! #amount do L.push zeroMutez
        ! #arg L.unit
      L.|:| L.nil
    , L.unit
    )

test_nonUnitParamToImplicitAccount_fails :: TestTree
test_nonUnitParamToImplicitAccount_fails =
  testScenario "`transfer` fails when param for an implicit account is not Unit" $ scenario do
    addr <- newFreshAddress "alias"
    transfer TransferData
      { tdTo = addr
      , tdAmount = 2
      , tdEntrypoint = DefEpName
      , tdParameter = (2 :: Natural)
      }
      & shouldFailWithMessage "Bad contract parameter for: "

testZeroTransactionFails :: MonadCleveland caps m => m ()
testZeroTransactionFails = do
  wallet <- newAddress "wallet"
  let
    transferData = TransferData
      { tdTo = wallet
      , tdAmount = 0
      , tdEntrypoint = DefEpName
      , tdParameter = ()
      }

  expectTransferFailure emptyTransaction (transfer transferData)

testZeroTransactionSuccess :: MonadCleveland caps m => m ()
testZeroTransactionSuccess = do
  address <- originateSimple @MText "test0tzContract" True idContract
  let
    transferData = TransferData
      { tdTo = address
      , tdAmount = 0
      , tdEntrypoint = DefEpName
      , tdParameter = "aaa" :: MText
      }

  transfer transferData