module Lorentz.Test.Integrational
(
TxData (..)
, genesisAddresses
, genesisAddress
, genesisAddress1
, genesisAddress2
, genesisAddress3
, genesisAddress4
, genesisAddress5
, genesisAddress6
, tOriginate
, tTransfer
, tExpectStorageConst
, I.IntegrationalValidator
, SuccessValidator
, IntegrationalScenarioM
, I.IntegrationalScenario
, I.ValidationError (..)
, I.integrationalTestExpectation
, I.integrationalTestProperty
, lOriginate
, lOriginateEmpty
, lTransfer
, lCall
, I.validate
, 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
, lExpectStorageConst
, lExpectMichelsonFailed
, lExpectFailWith
, lExpectError
, lExpectErrorNumeric
, lExpectCustomError
, lExpectCustomErrorNumeric
, lExpectCustomError_
, lExpectCustomErrorNumeric_
, lExpectConsumerStorage
, lExpectViewConsumerStorage
) where
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 as L
import Lorentz.Constraints
import Lorentz.Run
import Lorentz.Value
import Michelson.Interpret (InterpretError(..), MichelsonFailed(..))
import Michelson.Runtime
import Michelson.Runtime.GState
import Michelson.Test.Integrational (IntegrationalScenarioM, SuccessValidator)
import qualified Michelson.Test.Integrational as I
import Michelson.TypeCheck (typeVerifyValue)
import qualified Michelson.Typed as T
import Michelson.Typed.Scope
import Tezos.Core
import Util.Named ((.!))
tOriginate
:: (ParameterScope cp, StorageScope st)
=> T.Contract cp st -> Text -> T.Value st -> Mutez -> IntegrationalScenarioM Address
tOriginate contract name value balance =
I.originate (T.convertContract contract) name (T.untypeValue value) balance
lOriginate
:: forall cp st.
(NiceParameter cp, NiceStorage st)
=> L.Contract cp st
-> Text
-> st
-> Mutez
-> IntegrationalScenarioM (ContractRef cp)
lOriginate contract name value balance =
withDict (niceParameterEvi @cp) $
withDict (niceStorageEvi @st) $ do
addr <- tOriginate (compileLorentz contract) name (T.toVal value) balance
return (L.ContractRef addr def)
lOriginateEmpty
:: (NiceParameter cp, NiceStorage st, Default st)
=> L.Contract cp st
-> Text
-> IntegrationalScenarioM (ContractRef cp)
lOriginateEmpty contract name = lOriginate contract name def (unsafeMkMutez 0)
tTransfer
:: forall cp.
(ParameterScope cp)
=> "from" :! Address
-> "to" :! Address
-> Mutez
-> T.Value cp
-> IntegrationalScenarioM ()
tTransfer (arg #from -> from) (arg #to -> to) money param =
let txData = TxData
{ tdSenderAddress = from
, tdParameter =
withDict (properParameterEvi @cp) $
T.untypeValue param
, tdAmount = money
}
in I.transfer txData to
lTransfer
:: forall cp contract.
(NiceParameter cp, ToContractRef cp contract)
=> "from" :! Address
-> "to" :! contract
-> Mutez
-> cp
-> IntegrationalScenarioM ()
lTransfer from (convertContractRef @cp @Address . arg #to -> to) money param =
withDict (niceParameterEvi @cp) $
tTransfer from (#to .! to) money (T.toVal param)
lCall
:: forall cp contract.
(NiceParameter cp, ToContractRef cp contract)
=> contract -> cp -> IntegrationalScenarioM ()
lCall contract param =
lTransfer (#from .! genesisAddress) (#to .! contract)
(unsafeMkMutez 0) param
lExpectStorageUpdate
:: forall st addr.
(NiceStorage st, ToAddress addr, HasCallStack)
=> addr -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectStorageUpdate (toAddress -> addr) predicate =
I.expectStorageUpdate 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"
lExpectBalance :: ToAddress addr => addr -> Mutez -> SuccessValidator
lExpectBalance (toAddress -> addr) money = I.expectBalance addr money
tExpectStorageConst
:: forall st.
(StorageScope st)
=> Address -> Value st -> SuccessValidator
tExpectStorageConst addr expected =
I.expectStorageConst addr (T.untypeValue expected)
lExpectStorageConst
:: forall st addr.
(NiceStorage st, ToAddress addr)
=> addr -> st -> SuccessValidator
lExpectStorageConst (toAddress -> addr) expected =
withDict (niceStorageEvi @st) $
tExpectStorageConst addr (T.toVal expected)
lExpectMichelsonFailed
:: forall addr. (ToAddress addr)
=> (MichelsonFailed -> Bool) -> addr -> InterpreterError -> Bool
lExpectMichelsonFailed predicate (toAddress -> addr) =
I.expectMichelsonFailed predicate addr
lExpectFailWith
:: forall e.
(Typeable (T.ToT e), T.IsoValue e)
=> (e -> Bool) -> InterpreterError -> Bool
lExpectFailWith predicate =
\case
IEInterpreterFailed _ (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) -> InterpreterError -> Bool
lExpectError = lExpectError' L.errorFromVal
lExpectErrorNumeric
:: forall e.
(L.IsError e)
=> L.ErrorTagMap -> (e -> Bool) -> InterpreterError -> Bool
lExpectErrorNumeric errorTagMap =
lExpectError' (L.errorFromValNumeric errorTagMap)
lExpectError' ::
forall e.
(forall t. (Typeable t, SingI t) =>
Value t -> Either Text e)
-> (e -> Bool)
-> InterpreterError
-> Bool
lExpectError' errorFromValImpl predicate =
\case
IEInterpreterFailed _ (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 -> InterpreterError -> 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 -> InterpreterError -> Bool
lExpectCustomErrorNumeric errorTagMap l a =
lExpectErrorNumeric errorTagMap (== L.CustomError l a)
lExpectCustomError_
:: forall tag.
(L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())
=> Label tag -> InterpreterError -> Bool
lExpectCustomError_ l =
lExpectCustomError l ()
lExpectCustomErrorNumeric_
:: forall tag.
(L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())
=> L.ErrorTagMap -> Label tag -> InterpreterError -> Bool
lExpectCustomErrorNumeric_ errorTagMap l =
lExpectCustomErrorNumeric errorTagMap l ()
lExpectConsumerStorage
:: forall cp st contract.
(st ~ [cp], NiceStorage st, ToContractRef cp contract)
=> contract -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectConsumerStorage = lExpectStorageUpdate . toContractRef @cp
lExpectViewConsumerStorage
:: ( st ~ [cp]
, Eq cp, Buildable cp
, NiceStorage st
, ToContractRef cp contract
)
=> contract -> [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 |+ ""