FailureSequence.hs

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

{-# LANGUAGE QualifiedDo, NoApplicativeDo #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}

module TestSuite.Cleveland.FailureSequence
  ( test_FailureSequence
  , test_FailureTree
  ) where

import Lorentz qualified as L
import Lorentz.Instr as L
import Lorentz.Macro as L

import Test.Tasty (TestTree)

import Morley.Michelson.Typed (untypeValueOptimized)
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Crypto.Util (encodeBase58Check)
import Morley.Util.Interpolate (itu)
import Test.Cleveland
import Test.Cleveland.Internal.Abstract (Sender(..), senderL)
import TestSuite.Util
import TestSuite.Util.Contracts (inContractsDir)

test_FailureSequence :: TestTree
test_FailureSequence =
  testScenario "Prints contract call sequence on failure" $ scenario do
    testContract <- importContract @Integer @Natural @() $
      inContractsDir "call_self_several_times_then_fail_in_view.tz"
    contractHndl <- originate "Test failure call sequence" 0 testContract [tz|100u|]
    Sender (toAddress -> senderAddr) <- Prelude.view senderL

    let contractAddr = toAddress contractHndl

    msg <- ifEmulation
      (pure [itu|
        Call chain:
        - Transfer to #{contractAddr} entrypoint <default> from
          #{senderAddr} with parameter '9' and amount 0 μꜩ
        - Transfer to #{contractAddr} entrypoint <default> from
          #{contractAddr} with parameter '8' and amount 1 μꜩ
        - Transfer to #{contractAddr} entrypoint <default> from
          #{contractAddr} with parameter '7' and amount 1 μꜩ
        - Transfer to #{contractAddr} entrypoint <default> from
          #{contractAddr} with parameter '6' and amount 1 μꜩ

        |])
      (pure [itu|
        Call chain:
        - Transaction with amount: 0 μꜩ, destination:
          #{contractAddr}, and parameter:
          entrypoint: default, value: 9
        - Transaction with amount: 1 μꜩ, destination:
          #{contractAddr}, and parameter:
          entrypoint: default, value: 8
        - Transaction with amount: 1 μꜩ, destination:
          #{contractAddr}, and parameter:
          entrypoint: default, value: 7
        - Transaction with amount: 1 μꜩ, destination:
          #{contractAddr}, and parameter:
          entrypoint: default, value: 6

        |])

    transfer contractHndl (calling def 9) &
      shouldFailWithMessage msg

test_FailureTree :: TestTree
test_FailureTree =
  testScenario "Prints only the last branch of the call tree on failure" $ scenario do
    (callingSelf, callingOther, callingTree) <- inBatch $
      (,,) <$> (L.toContractRef <$> originate "CallingSelf" () callingSelfCt)
           <*> (L.toContractRef <$> originate "CallingOther" () callingOtherCt)
           <*> (originate "CallingTree" () callingTreeCt)
    Sender (toAddress -> senderAddr) <- Prelude.view senderL

    let selfBs = formatAddr $ toAddress callingSelf
        otherBs = formatAddr $ toAddress callingOther
        -- annoyingly, address is passed as bytes, and when we get it as
        -- Expression from network, it's like this.
        formatAddr = encodeBase58Check . unBytes . untypeValueOptimized . L.toVal
        unBytes = \case
          U.ValueBytes (U.InternalByteString bs) -> bs
          _ -> error "impossible"
        callingTreeAddr = toAddress callingTree
        callingSelfAddr = toAddress callingSelf
        callingOtherAddr = toAddress callingOther

    msg <- ifEmulation
      (pure [itu|
        Call chain:
        - Transfer to #{callingTreeAddr} entrypoint <default> from
          #{senderAddr} with parameter
            Pair
              "#{callingSelfAddr}"
              "#{callingOtherAddr}"
          and amount 0 μꜩ
        - Transfer to #{callingSelfAddr} entrypoint <default> from
          #{callingTreeAddr} with parameter '-1' and amount 0 μꜩ

        |])
      (pure [itu|
        Call chain:
        - Transaction with amount: 0 μꜩ, destination:
          #{callingTreeAddr}, and parameter:
          entrypoint: default, value:
          [#{selfBs}, #{otherBs}]
        - Transaction with amount: 0 μꜩ, destination:
          #{callingSelfAddr}, and parameter:
          entrypoint: default, value: -1

        |])

    addr <- newFreshAddress auto

    inBatch (transfer addr [tz|100u|] *> transfer callingTree (calling def (callingSelf, callingOther))) &
      shouldFailWithMessage msg

    transfer callingTree (calling def (callingSelf, callingOther)) &
      shouldFailWithMessage msg

callingSelfCt :: L.Contract Integer () ()
callingSelfCt = L.defaultContract L.do
  car
  dup
  dup
  isNat
  assertSome [L.mt|foobar|]
  L.drop
  ifEq0 (L.drop L.# unit L.# nil L.# pair) L.do
    push @Integer 1
    rsub
    dip L.do
      selfCalling @Integer CallDefault
      push 0
    transferTokens
    dip nil
    cons
    dip unit
    pair

callingOtherCt :: L.Contract (L.ContractRef Integer) () ()
callingOtherCt = L.defaultContract L.do
  car
  push 0
  push 5
  transferTokens
  dip nil
  cons
  dip unit
  pair

callingTreeCt :: L.Contract (L.ContractRef Integer, L.ContractRef (L.ContractRef Integer)) () ()
callingTreeCt = L.defaultContract L.do
  car
  unpair
  dup
  dip L.do
    dip $ push 0
    transferTokens
    dip nil
  push 0
  push (-1)
  transferTokens
  L.swap
  dip cons
  cons
  dip unit
  pair