Integrational.hs

-- | Mirrors 'Michelson.Test.Integrational' module in a Lorentz way.
module Lorentz.Test.Integrational
  (
    -- * Re-exports
    TxData (..)
  , genesisAddresses
  , genesisAddress
  -- * More genesis addresses which can be used in tests
  , genesisAddress1
  , genesisAddress2
  , genesisAddress3
  , genesisAddress4
  , genesisAddress5
  , genesisAddress6

    -- * Testing engine for bare Typed primitives
  , I.tOriginate
  , I.tTransfer
  , I.tExpectStorageConst

    -- * Testing engine
  , I.IntegrationalValidator
  , SuccessValidator
  , IntegrationalScenarioM
  , I.IntegrationalScenario
  , I.ValidationError (..)
  , I.integrationalTestExpectation
  , I.integrationalTestProperty
  , lOriginate
  , lOriginateEmpty
  , lTransfer
  , lCall
  , lCallEP
  , EntryPointRef (..)
  , lCallDef
  , I.validate
  , I.integrationalFail
  , I.setMaxSteps
  , I.setNow
  , I.rewindTime
  , I.withSender
  , I.setChainId
  , I.branchout
  , (I.?-)
  , I.offshoot

  -- * Validators
  , I.composeValidators
  , I.composeValidatorsList
  , I.expectAnySuccess
  , I.expectNoUpdates
  , I.expectNoStorageUpdates
  , lExpectStorageUpdate
  , lExpectBalance
  , lExpectStorage
  , lExpectStorageConst
  -- * Errors
  , lExpectMichelsonFailed
  , lExpectFailWith
  , lExpectError
  , lExpectErrorNumeric
  , lExpectCustomError
  , lExpectCustomErrorNumeric
  , lExpectCustomError_
  , lExpectCustomErrorNumeric_

  -- ** Consumer
  , lExpectConsumerStorage
  , lExpectViewConsumerStorage
  ) where

import Data.Constraint (Dict(..))
import Data.Default (Default(..))
import Data.Singletons (SingI)
import Data.Typeable (gcast)
import Fmt (Buildable, listF, (+|), (|+))
import Named ((:!), arg)

import qualified Lorentz.Base as L
import Lorentz.Constraints
import Lorentz.EntryPoints
import qualified Lorentz.Errors as L
import qualified Lorentz.Errors.Numeric as L
import Lorentz.Run
import Lorentz.Value
import qualified Lorentz.Value as L
import Michelson.Interpret (InterpretError(..), MichelsonFailed(..))
import Michelson.Runtime
import Michelson.Runtime.GState
import Michelson.Test.Integrational
import qualified Michelson.Test.Integrational as I
import Michelson.TypeCheck (typeCheckValue)
import qualified Michelson.Typed as T
import qualified Michelson.Untyped as U
import Tezos.Core
import Util.Label (Label)
import Util.Named ((.!))

----------------------------------------------------------------------------
-- Interface
----------------------------------------------------------------------------

-- TODO: how to call they normally? :thinking:
-- Preserving just the same names like @transfer@ or @originate@
-- looks very bad because no one will import this or
-- 'Michelson.Test.Integrational' module qualified
-- and thus finding which exact function is used would become too painful.

-- | Like 'originate', but for Lorentz contracts.
lOriginate
  :: forall cp st.
     (NiceParameterFull cp, NiceStorage st)
  => L.ContractCode cp st
  -> Text
  -> st
  -> Mutez
  -> IntegrationalScenarioM (TAddress cp)
lOriginate contract name value balance =
  withDict (niceParameterEvi @cp) $
  withDict (niceStorageEvi @st) $ do
    addr <- I.tOriginate (compileLorentzContract contract) name (T.toVal value) balance
    return (L.TAddress addr)

-- | Originate a contract with empty balance and default storage.
lOriginateEmpty
  :: (NiceParameterFull cp, NiceStorage st, Default st)
  => L.ContractCode cp st
  -> Text
  -> IntegrationalScenarioM (TAddress cp)
lOriginateEmpty contract name = lOriginate contract name def (unsafeMkMutez 0)

-- | Similar to 'transfer', for Lorentz values.
lTransfer
  :: forall cp epRef epArg addr.
     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr)
  => "from" :! Address
  -> "to" :! addr
  -> Mutez
  -> epRef
  -> epArg
  -> IntegrationalScenarioM ()
lTransfer from (toTAddress @cp . arg #to -> TAddress to) money epRef param =
  case useHasEntryPointArg @cp @epRef @epArg epRef of
    (Dict, epName) -> I.tTransfer from (#to .! to) money epName (T.toVal param)

{-# DEPRECATED lCall "'lCall' will likely be replaced with 'lCallEP' in future version" #-}
-- | Legacy version of 'lCallEP' function. Calls default entrypoint of
-- a contract assuming its argument is the same as contract parameter
-- (which is equivalent to absence of explicit default entrypoint).
--
-- This function is DEPRECATED and exists only for backwards compatibility.
lCall
  :: forall cp defEpName addr.
     ( HasDefEntryPointArg cp defEpName cp
     , IsoValue cp
     , ToTAddress cp addr
     )
  => addr -> cp -> IntegrationalScenarioM ()
lCall = lCallDef @cp @defEpName @cp @addr

-- | Call an entrypoint of a contract without caring about the source
-- address. Transfers 0 mutez.
lCallEP
  :: forall cp epRef epArg addr.
     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr)
  => addr -> epRef -> epArg -> IntegrationalScenarioM ()
lCallEP addr epRef param =
  lTransfer @cp @epRef @epArg
    (#from .! genesisAddress) (#to .! addr)
    (unsafeMkMutez 0) epRef param

-- | 'lCallEP' for default entrypoint.
lCallDef
  :: forall cp defEpName defArg addr.
     ( HasDefEntryPointArg cp defEpName defArg
     , IsoValue defArg
     , ToTAddress cp addr
     )
  => addr -> defArg -> IntegrationalScenarioM ()
lCallDef addr =
  lCallEP @cp @defEpName @defArg addr CallDefault

----------------------------------------------------------------------------
-- Validators to be used within 'IntegrationalValidator'
----------------------------------------------------------------------------

-- Expect something successful

-- | Internal function that proceeds storage validation from by untyping
-- the value passed to callback.
validateStorageCb
  :: forall st addr.
     (NiceStorage st, ToAddress addr, HasCallStack)
  => (Address -> (U.Value -> Either ValidationError ()) -> SuccessValidator)
  -> addr -> (st -> Either I.ValidationError ()) -> SuccessValidator
validateStorageCb validator (toAddress -> addr) predicate =
  validator addr $ \got -> do
    val <- first I.UnexpectedTypeCheckError $ typeCheck got
    predicate $ T.fromVal val
  where
    typeCheck uval =
      evaluatingState initSt . runExceptT $
      usingReaderT def $
      typeCheckValue uval
    initSt = error "Typechecker state unavailable"

-- | Similar to 'expectStorage', but for Lorentz values.
lExpectStorage
  :: forall st addr.
     (NiceStorage st, ToAddress addr, HasCallStack)
  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectStorage = validateStorageCb I.expectStorage

-- | Similar to 'expectStorageUpdate', but for Lorentz values.
lExpectStorageUpdate
  :: forall st addr.
     (NiceStorage st, ToAddress addr, HasCallStack)
  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectStorageUpdate = validateStorageCb I.expectStorageUpdate

-- | Like 'expectBalance', for Lorentz values.
lExpectBalance :: ToAddress addr => addr -> Mutez -> SuccessValidator
lExpectBalance (toAddress -> addr) money = I.expectBalance addr money

-- | Similar to 'expectStorageConst', for Lorentz values.
lExpectStorageConst
  :: forall st addr.
     (NiceStorage st, ToAddress addr)
  => addr -> st -> SuccessValidator
lExpectStorageConst (toAddress -> addr) expected =
  withDict (niceStorageEvi @st) $
    I.tExpectStorageConst addr (T.toVal expected)

-- Expect errors

-- | Expect that interpretation of contract with given address ended
-- with [FAILED].
lExpectMichelsonFailed
  :: forall addr. (ToAddress addr)
  => (MichelsonFailed -> Bool) -> addr -> ExecutorError -> Bool
lExpectMichelsonFailed predicate (toAddress -> addr) =
  I.expectMichelsonFailed predicate addr

-- | Expect contract to fail with "FAILWITH" instruction and provided value
-- to match against the given predicate.
lExpectFailWith
  :: forall e.
      (Typeable (T.ToT e), T.IsoValue e)
  => (e -> Bool) -> ExecutorError -> Bool
lExpectFailWith predicate =
  \case
    EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) ->
        case gcast err of
          Just errT -> predicate $ T.fromVal @e errT
          Nothing -> False
    _ -> False

-- | Expect contract to fail with given error.
lExpectError
  :: forall e.
      (L.IsError e)
  => (e -> Bool) -> ExecutorError -> Bool
lExpectError = lExpectError' L.errorFromVal

-- | Version of 'lExpectError' for the case when numeric
-- representation of errors is used.
lExpectErrorNumeric
  :: forall e.
      (L.IsError e)
  => L.ErrorTagMap -> (e -> Bool) -> ExecutorError -> Bool
lExpectErrorNumeric errorTagMap =
  lExpectError' (L.errorFromValNumeric errorTagMap)

lExpectError' ::
     forall e.
     (forall t. (Typeable t, SingI t) =>
                  Value t -> Either Text e)
  -> (e -> Bool)
  -> ExecutorError
  -> Bool
lExpectError' errorFromValImpl predicate =
  \case
    EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) ->
        case errorFromValImpl err of
          Right err' -> predicate err'
          Left _ -> False
    _ -> False

-- | Expect contract to fail with given 'CustomError'.
lExpectCustomError
  :: forall tag arg.
      (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg)
  => Label tag -> arg -> ExecutorError -> Bool
lExpectCustomError l a =
  lExpectError (== L.CustomError l a)

-- | Version of 'lExpectCustomError' for the case when numeric
-- representation of errors is used.
lExpectCustomErrorNumeric
  :: forall tag arg.
      (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg)
  => L.ErrorTagMap -> Label tag -> arg -> ExecutorError -> Bool
lExpectCustomErrorNumeric errorTagMap l a =
  lExpectErrorNumeric errorTagMap (== L.CustomError l a)

-- | Specialization of 'lExpectCustomError' for non-arg error case.
lExpectCustomError_
  :: forall tag.
      (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())
  => Label tag -> ExecutorError -> Bool
lExpectCustomError_ l =
  lExpectCustomError l ()

-- | Version of 'lExpectCustomError_' for the case when numeric
-- representation of errors is used.
lExpectCustomErrorNumeric_
  :: forall tag.
      (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())
  => L.ErrorTagMap -> Label tag -> ExecutorError -> Bool
lExpectCustomErrorNumeric_ errorTagMap l =
  lExpectCustomErrorNumeric errorTagMap l ()

-- Consumer

-- | Version of 'lExpectStorageUpdate' specialized to "consumer" contract
-- (see 'Lorentz.Contracts.Consumer.contractConsumer').
lExpectConsumerStorage
  :: forall cp st addr.
     (st ~ [cp], NiceStorage st, ToTAddress cp addr)
  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectConsumerStorage addr = lExpectStorageUpdate (toTAddress @cp addr)

-- | Assuming that "consumer" contract receives a value from 'View', expect
-- this view return value to be the given one.
--
-- Despite consumer stores parameters it was called with in reversed order,
-- this function cares about it, so you should provide a list of expected values
-- in the same order in which the corresponding events were happenning.
lExpectViewConsumerStorage
  :: ( st ~ [cp]
     , Eq cp, Buildable cp
     , NiceStorage st
     , ToTAddress cp addr
     )
  => addr -> [cp] -> SuccessValidator
lExpectViewConsumerStorage addr expected =
  lExpectConsumerStorage addr (matchExpected . reverse)
  where
    mkError = Left . I.CustomValidationError
    matchExpected got
      | got == expected = pass
      | otherwise = mkError $ "Expected " +| listF expected |+
                              ", but got " +| listF got |+ ""