module Morley.Test.Integrational
(
TxData (..)
, genesisAddress
, IntegrationalValidator
, SuccessValidator
, IntegrationalScenario
, integrationalTestExpectation
, integrationalTestProperty
, originate
, transfer
, validate
, setMaxSteps
, setNow
, composeValidators
, composeValidatorsList
, expectAnySuccess
, expectStorageUpdate
, expectStorageUpdateConst
, expectBalance
, expectStorageConst
, expectGasExhaustion
, expectMichelsonFailed
) where
import Control.Lens (assign, at, makeLenses, (.=), (<>=))
import Control.Monad.Except (Except, runExcept, throwError)
import qualified Data.List as List
import Fmt (blockListF, pretty, (+|), (|+))
import Test.Hspec (Expectation, expectationFailure)
import Test.QuickCheck (Property)
import Michelson.Interpret (InterpretUntypedError(..), MichelsonFailed(..), RemainingSteps)
import Michelson.Untyped
(OriginationOperation(..), UntypedContract, UntypedValue, mkContractAddress)
import Morley.Runtime (InterpreterError(..), InterpreterOp(..), InterpreterRes(..), interpreterPure)
import Morley.Runtime.GState
import Morley.Runtime.TxData
import Morley.Test.Dummy
import Morley.Test.Util (failedProp, succeededProp)
import Tezos.Address (Address)
import Tezos.Core (Mutez, Timestamp)
data InternalState = InternalState
{ _isMaxSteps :: !RemainingSteps
, _isNow :: !Timestamp
, _isGState :: !GState
, _isOperations :: ![InterpreterOp]
}
makeLenses ''InternalState
type IntegrationalValidator = Either (InterpreterError -> Bool) SuccessValidator
type SuccessValidator = (GState -> [GStateUpdate] -> Either Text ())
type IntegrationalScenarioM = StateT InternalState (Except Text)
data Validated = Validated
type IntegrationalScenario = IntegrationalScenarioM Validated
integrationalTestExpectation :: IntegrationalScenario -> Expectation
integrationalTestExpectation =
integrationalTest (maybe pass (expectationFailure . toString))
integrationalTestProperty :: IntegrationalScenario -> Property
integrationalTestProperty = integrationalTest (maybe succeededProp failedProp)
originate ::
UntypedContract -> UntypedValue -> Mutez -> IntegrationalScenarioM Address
originate contract value balance =
mkContractAddress origination <$ putOperation originateOp
where
origination = (dummyOrigination value contract) {ooBalance = balance}
originateOp = OriginateOp origination
transfer :: TxData -> Address -> IntegrationalScenarioM ()
transfer txData destination =
putOperation (TransferOp destination txData)
validate :: IntegrationalValidator -> IntegrationalScenario
validate validator = Validated <$ do
now <- use isNow
maxSteps <- use isMaxSteps
gState <- use isGState
ops <- use isOperations
mUpdatedGState <-
lift $ validateResult validator $ interpreterPure now maxSteps gState ops
isOperations .= mempty
whenJust mUpdatedGState $ \newGState -> isGState .= newGState
setNow :: Timestamp -> IntegrationalScenarioM ()
setNow = assign isNow
setMaxSteps :: RemainingSteps -> IntegrationalScenarioM ()
setMaxSteps = assign isMaxSteps
putOperation :: InterpreterOp -> IntegrationalScenarioM ()
putOperation op = isOperations <>= one op
expectAnySuccess :: SuccessValidator
expectAnySuccess _ _ = pass
expectStorageUpdate ::
Address
-> (UntypedValue -> Either Text ())
-> SuccessValidator
expectStorageUpdate addr predicate _ updates =
case List.find checkAddr (reverse updates) of
Nothing -> Left $ "Storage of " +| addr |+ " is not updated"
Just (GSSetStorageValue _ val) ->
first (("Storage of " +| addr |+ "is updated incorrectly: ") <>) $
predicate val
Just _ -> error "expectStorageUpdate: internal error"
where
checkAddr (GSSetStorageValue addr' _) = addr' == addr
checkAddr _ = False
expectStorageUpdateConst ::
Address
-> UntypedValue
-> SuccessValidator
expectStorageUpdateConst addr expected =
expectStorageUpdate addr predicate
where
predicate val
| val == expected = pass
| otherwise = Left $ "expected " +| expected |+ ""
expectStorageConst :: Address -> UntypedValue -> SuccessValidator
expectStorageConst addr expected gs _ =
case gsAddresses gs ^. at addr of
Just (ASContract cs)
| csStorage cs == expected -> pass
| otherwise ->
Left $ intro +| "its storage is " +| csStorage cs |+ ""
Just (ASSimple {}) ->
Left $ intro +| "it's a simple address"
Nothing -> Left $ intro +| "it's unknown"
where
intro = "Expected " +| addr |+ " to have storage " +| expected |+ ", but "
expectBalance :: Address -> Mutez -> SuccessValidator
expectBalance addr balance gs _ =
case gsAddresses gs ^. at addr of
Nothing ->
Left $
"Expected " +| addr |+ " to have balance " +| balance |+
", but it's unknown"
Just (asBalance -> realBalance)
| realBalance == balance -> pass
| otherwise ->
Left $
"Expected " +| addr |+ " to have balance " +| balance |+
", but its balance is " +| realBalance |+ ""
composeValidators ::
SuccessValidator
-> SuccessValidator
-> SuccessValidator
composeValidators val1 val2 gState updates =
val1 gState updates >> val2 gState updates
composeValidatorsList :: [SuccessValidator] -> SuccessValidator
composeValidatorsList = foldl' composeValidators expectAnySuccess
expectGasExhaustion :: InterpreterError -> Bool
expectGasExhaustion =
\case
IEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> True
_ -> False
expectMichelsonFailed :: Address -> InterpreterError -> Bool
expectMichelsonFailed addr =
\case
IEInterpreterFailed failedAddr (RuntimeFailure {}) -> addr == failedAddr
_ -> False
initIS :: InternalState
initIS = InternalState
{ _isNow = dummyNow
, _isMaxSteps = dummyMaxSteps
, _isGState = initGState
, _isOperations = mempty
}
integrationalTest ::
(Maybe Text -> res)
-> IntegrationalScenario
-> res
integrationalTest howToFail scenario =
howToFail $ leftToMaybe $ runExcept (runStateT scenario initIS)
validateResult ::
IntegrationalValidator
-> Either InterpreterError InterpreterRes
-> Except Text (Maybe GState)
validateResult validator result =
case (validator, result) of
(Left validateError, Left err)
| validateError err -> pure Nothing
(_, Left err) ->
doFail $ "Unexpected interpreter error: " <> pretty err
(Left _, Right _) ->
doFail $ "Interpreter unexpectedly didn't fail"
(Right validateUpdates, Right ir)
| Left bad <- validateUpdates (_irGState ir) (_irUpdates ir) ->
doFail $
"Updates are incorrect: " +| bad |+ ". Updates are: \n" +|
blockListF (_irUpdates ir) |+ ""
| otherwise -> pure $ Just $ _irGState ir
where
doFail = throwError