module Lorentz.Test.Integrational
(
TxData (..)
, genesisAddresses
, genesisAddress
, genesisAddress1
, genesisAddress2
, genesisAddress3
, genesisAddress4
, genesisAddress5
, genesisAddress6
, I.tOriginate
, I.tTransfer
, I.tExpectStorageConst
, 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
, I.composeValidators
, I.composeValidatorsList
, I.expectAnySuccess
, I.expectNoUpdates
, I.expectNoStorageUpdates
, lExpectStorageUpdate
, lExpectBalance
, lExpectStorage
, lExpectStorageConst
, lExpectMichelsonFailed
, lExpectFailWith
, lExpectError
, lExpectErrorNumeric
, lExpectCustomError
, lExpectCustomErrorNumeric
, lExpectCustomError_
, lExpectCustomErrorNumeric_
, lExpectConsumerStorage
, lExpectViewConsumerStorage
) where
import Data.Constraint (Dict(..))
import Data.Default (Default(..))
import Data.Singletons (SingI)
import Data.Typeable (gcast)
import Data.Vinyl.Derived (Label)
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 (typeVerifyValue)
import qualified Michelson.Typed as T
import qualified Michelson.Untyped as U
import Tezos.Core
import Util.Named ((.!))
lOriginate
:: forall cp st.
(NiceParameterFull cp, NiceStorage st)
=> L.Contract 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)
lOriginateEmpty
:: (NiceParameterFull cp, NiceStorage st, Default st)
=> L.Contract cp st
-> Text
-> IntegrationalScenarioM (TAddress cp)
lOriginateEmpty contract name = lOriginate contract name def (unsafeMkMutez 0)
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" #-}
lCall
:: forall cp defEpName addr.
( HasDefEntryPointArg cp defEpName cp
, IsoValue cp
, ToTAddress cp addr
)
=> addr -> cp -> IntegrationalScenarioM ()
lCall = lCallDef @cp @defEpName @cp @addr
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
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
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 $
typeVerifyValue uval
initSt = error "Typechecker state unavailable"
lExpectStorage
:: forall st addr.
(NiceStorage st, ToAddress addr, HasCallStack)
=> addr -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectStorage = validateStorageCb I.expectStorage
lExpectStorageUpdate
:: forall st addr.
(NiceStorage st, ToAddress addr, HasCallStack)
=> addr -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectStorageUpdate = validateStorageCb I.expectStorageUpdate
lExpectBalance :: ToAddress addr => addr -> Mutez -> SuccessValidator
lExpectBalance (toAddress -> addr) money = I.expectBalance addr money
lExpectStorageConst
:: forall st addr.
(NiceStorage st, ToAddress addr)
=> addr -> st -> SuccessValidator
lExpectStorageConst (toAddress -> addr) expected =
withDict (niceStorageEvi @st) $
I.tExpectStorageConst addr (T.toVal expected)
lExpectMichelsonFailed
:: forall addr. (ToAddress addr)
=> (MichelsonFailed -> Bool) -> addr -> ExecutorError -> Bool
lExpectMichelsonFailed predicate (toAddress -> addr) =
I.expectMichelsonFailed predicate addr
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
lExpectError
:: forall e.
(L.IsError e)
=> (e -> Bool) -> ExecutorError -> Bool
lExpectError = lExpectError' L.errorFromVal
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
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)
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)
lExpectCustomError_
:: forall tag.
(L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())
=> Label tag -> ExecutorError -> Bool
lExpectCustomError_ l =
lExpectCustomError l ()
lExpectCustomErrorNumeric_
:: forall tag.
(L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())
=> L.ErrorTagMap -> Label tag -> ExecutorError -> Bool
lExpectCustomErrorNumeric_ errorTagMap l =
lExpectCustomErrorNumeric errorTagMap l ()
lExpectConsumerStorage
:: forall cp st addr.
(st ~ [cp], NiceStorage st, ToTAddress cp addr)
=> addr -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectConsumerStorage addr = lExpectStorageUpdate (toTAddress @cp addr)
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 |+ ""