module Michelson.Test.Integrational
(
TxData (..)
, genesisAddress
, genesisAddress1
, genesisAddress2
, genesisAddress3
, genesisAddress4
, genesisAddress5
, genesisAddress6
, IntegrationalValidator
, SuccessValidator
, IntegrationalScenarioM
, IntegrationalScenario
, ValidationError (..)
, integrationalTestExpectation
, integrationalTestProperty
, originate
, tOriginate
, transfer
, tTransfer
, validate
, integrationalFail
, setMaxSteps
, modifyNow
, setNow
, rewindTime
, withSender
, setChainId
, branchout
, (?-)
, offshoot
, composeValidators
, composeValidatorsList
, expectAnySuccess
, expectNoUpdates
, expectNoStorageUpdates
, expectStorageUpdate
, expectStorageUpdateConst
, expectBalance
, expectStorage
, expectStorageConst
, tExpectStorageConst
, expectGasExhaustion
, expectMichelsonFailed
) where
import Control.Lens (assign, at, makeLenses, makeLensesFor, modifying, (%=), (.=), (<>=), (?=))
import Control.Monad.Except (Except, runExcept, throwError, withExcept)
import qualified Data.List as List
import Data.Map as Map (empty, insert, lookup)
import Fmt (Buildable(..), blockListF, listF, pretty, (+|), (|+))
import Named ((:!), arg)
import Test.Hspec (Expectation, expectationFailure)
import Test.QuickCheck (Property)
import Michelson.Interpret (InterpretError(..), MichelsonFailed(..), RemainingSteps)
import Michelson.Runtime
(ExecutorError, ExecutorError'(..), ExecutorOp(..), ExecutorRes(..), executorPure)
import Michelson.Runtime.GState
import Michelson.Runtime.TxData
import Michelson.Test.Dummy
import Michelson.Test.Util (failedProp, succeededProp)
import Michelson.TypeCheck (TCError)
import qualified Michelson.Typed as Typed
import Michelson.Typed.Scope (ParameterScope, StorageScope, properParameterEvi, withDict)
import Michelson.Untyped (Contract, EpName, OriginationOperation(..), Value, mkContractAddress)
import Tezos.Address (Address)
import Tezos.Core (ChainId, Mutez, Timestamp, timestampPlusSeconds, unsafeMkMutez)
type ExecutorResOrError = Either ExecutorError ExecutorRes
data InternalState = InternalState
{ _isMaxSteps :: RemainingSteps
, _isNow :: Timestamp
, _isGState :: GState
, _isInterpreterLog :: [ExecutorResOrError]
, _isExecutorResult :: Maybe ExecutorResOrError
, _isContractsNames :: Map Address Text
, _isSender :: Maybe Address
}
makeLenses ''InternalState
newtype ScenarioBranchName = ScenarioBranchName { unTestBranch :: [Text] }
instance Buildable ScenarioBranchName where
build = mconcat . intersperse "/" . map build . unTestBranch
type IntegrationalValidator = Either (ExecutorError -> Bool) SuccessValidator
type SuccessValidator = InternalState -> GState -> [GStateUpdate] -> Either ValidationError ()
type IntegrationalScenarioM = StateT InternalState (Except ScenarioError)
data Validated = Validated
type IntegrationalScenario = IntegrationalScenarioM Validated
newtype ExpectedStorage = ExpectedStorage Value deriving stock (Show)
newtype ExpectedBalance = ExpectedBalance Mutez deriving stock (Show)
data AddressName = AddressName (Maybe Text) Address deriving stock (Show)
addrToAddrName :: Address -> InternalState -> AddressName
addrToAddrName addr iState =
AddressName (lookup addr (iState ^. isContractsNames)) addr
instance Buildable AddressName where
build (AddressName mbName addr) =
build addr +| maybe "" (\cName -> " (" +|cName |+ ")") mbName
type IntegrationalExecutorError = ExecutorError' AddressName
data ValidationError
= UnexpectedExecutorError IntegrationalExecutorError
| UnexpectedTypeCheckError TCError
| ExpectingInterpreterToFail
| IncorrectUpdates ValidationError [GStateUpdate]
| IncorrectStorageUpdate AddressName Text
| InvalidStorage AddressName ExpectedStorage Text
| StoragePredicateMismatch AddressName Text
| InvalidBalance AddressName ExpectedBalance Text
| UnexpectedUpdates (NonEmpty GStateUpdate)
| CustomValidationError Text
deriving stock (Show)
instance Buildable ValidationError where
build (UnexpectedExecutorError iErr) =
"Unexpected interpreter error. Reason: " +| iErr |+ ""
build (UnexpectedTypeCheckError tcErr) =
"Unexpected type check error. Reason: " +| tcErr |+ ""
build ExpectingInterpreterToFail =
"Interpreter unexpectedly didn't fail"
build (IncorrectUpdates vErr updates) =
"Updates are incorrect: " +| vErr |+ " . Updates are:"
+| blockListF updates |+ ""
build (IncorrectStorageUpdate addr msg) =
"Storage of " +| addr |+ " is updated incorrectly: " +| msg |+ ""
build (InvalidStorage addr (ExpectedStorage expected) msg) =
"Expected " +| addr |+ " to have storage " +| expected |+ ", but " +| msg |+ ""
build (StoragePredicateMismatch addr msg) =
"Expected " +| addr |+ " to have storage that matches the predicate, but" +| msg |+ ""
build (InvalidBalance addr (ExpectedBalance expected) msg) =
"Expected " +| addr |+ " to have balance " +| expected |+ ", but " +| msg |+ ""
build (UnexpectedUpdates updates) =
"Did not expect certain updates, but there are some: " +| listF updates |+ ""
build (CustomValidationError msg) = pretty msg
instance Exception ValidationError where
displayException = pretty
data ScenarioError = ScenarioError
{ _seBranch :: ScenarioBranchName
, _seError :: ValidationError
}
makeLensesFor [("_seBranch", "seBranch")] ''ScenarioError
instance Buildable ScenarioError where
build (ScenarioError br err) =
let builtBranch
| nullScenarioBranch br = ""
| otherwise = "In '" +| br |+ "' branch:\n"
in builtBranch <> build err
integrationalTestExpectation
:: HasCallStack
=> IntegrationalScenario -> Expectation
integrationalTestExpectation =
integrationalTest (maybe pass (expectationFailure . pretty))
integrationalTestProperty :: IntegrationalScenario -> Property
integrationalTestProperty =
integrationalTest (maybe succeededProp (failedProp . pretty))
interpret :: [ExecutorOp] -> IntegrationalScenarioM ExecutorResOrError
interpret ops = do
now <- use isNow
maxSteps <- use isMaxSteps
gState <- use isGState
let interpretedResult = executorPure now maxSteps gState ops
whenRight interpretedResult $ \result -> isGState .= _erGState result
return interpretedResult
registerInterpretationIfNeeded :: [ExecutorOp] -> IntegrationalScenarioM ()
registerInterpretationIfNeeded ops = do
previousResult <- use isExecutorResult
case previousResult of
Just (Left _) -> pass
_ -> interpret ops >>= putResult
originate :: Contract -> Text -> Value -> Mutez -> IntegrationalScenarioM Address
originate contract contractName value balance = do
registerInterpretationIfNeeded [OriginateOp origination]
let address = mkContractAddress origination
isContractsNames %= insert address contractName
return address
where
origination = (dummyOrigination value contract) {ooBalance = balance}
tOriginate ::
(ParameterScope cp, StorageScope st)
=> Typed.FullContract cp st
-> Text
-> Typed.Value st
-> Mutez
-> IntegrationalScenarioM Address
tOriginate contract name value balance =
originate (Typed.convertFullContract contract) name
(Typed.untypeValue value) balance
transfer :: TxData -> Address -> IntegrationalScenarioM ()
transfer txData destination = do
mSender <- use isSender
let unwrappedData = maybe id (set tdSenderAddressL) mSender txData
registerInterpretationIfNeeded [TransferOp destination unwrappedData]
tTransfer
:: forall arg.
(ParameterScope arg)
=> "from" :! Address
-> "to" :! Address
-> Mutez
-> EpName
-> Typed.Value arg
-> IntegrationalScenarioM ()
tTransfer (arg #from -> from) (arg #to -> to) money epName param =
let txData = TxData
{ tdSenderAddress = from
, tdParameter =
withDict (properParameterEvi @arg) $
Typed.untypeValue param
, tdEntrypoint = epName
, tdAmount = money
}
in transfer txData to
validate :: IntegrationalValidator -> IntegrationalScenario
validate validator = Validated <$ do
iState <- get
interpreterResult <- use isExecutorResult
case interpreterResult of
Just result -> do
whenLeft result $ \_ -> isExecutorResult .= Nothing
validateResult validator result iState
_ ->
failWith "Validating empty scenario"
where
failWith = integrationalFail . CustomValidationError
integrationalFail :: ValidationError -> IntegrationalScenarioM anything
integrationalFail = throwError . ScenarioError emptyScenarioBranch
modifyNow :: (Timestamp -> Timestamp) -> IntegrationalScenarioM ()
modifyNow = modifying isNow
setNow :: Timestamp -> IntegrationalScenarioM ()
setNow time = modifyNow (const time)
rewindTime :: Integer -> IntegrationalScenarioM ()
rewindTime interval = modifyNow (flip timestampPlusSeconds interval)
setMaxSteps :: RemainingSteps -> IntegrationalScenarioM ()
setMaxSteps = assign isMaxSteps
withSender :: Address -> IntegrationalScenarioM a -> IntegrationalScenarioM a
withSender addr scenario = do
prevSender <- use isSender
isSender ?= addr
scenario <* (isSender .= prevSender)
setChainId :: ChainId -> IntegrationalScenarioM ()
setChainId = assign (isGState . gsChainIdL)
putResult :: ExecutorResOrError -> IntegrationalScenarioM ()
putResult res = do
isInterpreterLog <>= one res
isExecutorResult .= pure res
emptyScenarioBranch :: ScenarioBranchName
emptyScenarioBranch = ScenarioBranchName []
appendScenarioBranch :: Text -> ScenarioBranchName -> ScenarioBranchName
appendScenarioBranch brName (ScenarioBranchName branches) =
ScenarioBranchName (brName : branches)
nullScenarioBranch :: ScenarioBranchName -> Bool
nullScenarioBranch (ScenarioBranchName brs) = null brs
branchout :: HasCallStack => [(Text, IntegrationalScenario)] -> IntegrationalScenario
branchout scenarios = do
st <- get
res <- lift . forM scenarios $ \(name, scenario) ->
withExcept (seBranch %~ appendScenarioBranch name) $
evalStateT scenario st
case nonEmpty res of
Nothing -> error "branch: empty list of scenarios provided"
Just (validated :| _) -> pure validated
(?-) :: Text -> a -> (Text, a)
(?-) = (,)
infixr 0 ?-
offshoot :: Text -> IntegrationalScenario -> IntegrationalScenarioM ()
offshoot name scenario = do
st <- get
Validated <- lift $
withExcept (seBranch %~ appendScenarioBranch name) $
evalStateT scenario st
pass
expectAnySuccess :: SuccessValidator
expectAnySuccess _ _ _ = pass
expectNoUpdates :: SuccessValidator
expectNoUpdates _ _ updates =
maybe pass (throwError . UnexpectedUpdates) . nonEmpty $ updates
expectNoStorageUpdates :: SuccessValidator
expectNoStorageUpdates _ _ updates =
maybe pass (throwError . UnexpectedUpdates) . nonEmpty $
filter isStorageUpdate updates
where
isStorageUpdate = \case
GSSetStorageValue {} -> True
_ -> False
expectStorage
:: Address
-> (Value -> Either ValidationError ())
-> SuccessValidator
expectStorage addr predicate is gs _ =
case gsAddresses gs ^. at addr of
Just (ASContract cs) ->
predicate $ csStorage cs
Just (ASSimple {}) ->
Left $ intro $ "it's a simple address"
Nothing -> Left $ intro $ "it's unknown"
where
intro = StoragePredicateMismatch (addrToAddrName addr is)
expectStorageUpdate
:: Address
-> (Value -> Either ValidationError ())
-> SuccessValidator
expectStorageUpdate addr predicate is _ updates =
case List.find checkAddr (reverse updates) of
Nothing -> Left $
IncorrectStorageUpdate (addrToAddrName addr is) "storage wasn't updated"
Just (GSSetStorageValue _ val _) ->
first (IncorrectStorageUpdate (addrToAddrName addr is) . pretty) $
predicate val
Just _ -> error "expectStorageUpdate: internal error"
where
checkAddr (GSSetStorageValue addr' _ _) = addr' == addr
checkAddr _ = False
expectStorageUpdateConst
:: Address
-> Value
-> SuccessValidator
expectStorageUpdateConst addr expected is =
expectStorageUpdate addr predicate is
where
predicate val
| val == expected = pass
| otherwise = Left $
IncorrectStorageUpdate (addrToAddrName addr is) (pretty expected)
expectStorageConst :: Address -> Value -> SuccessValidator
expectStorageConst addr expected is = expectStorage addr predicate is
where
predicate val
| val == expected = pass
| otherwise = Left $
InvalidStorage (addrToAddrName addr is) (ExpectedStorage expected) (pretty val)
tExpectStorageConst
:: forall st.
(StorageScope st)
=> Address -> Typed.Value st -> SuccessValidator
tExpectStorageConst addr expected =
expectStorageConst addr (Typed.untypeValue expected)
expectBalance :: Address -> Mutez -> SuccessValidator
expectBalance addr balance is gs _ =
let realBalance = maybe (unsafeMkMutez 0) asBalance (gsAddresses gs ^. at addr) in
if realBalance == balance then pass
else
Left
$ InvalidBalance (addrToAddrName addr is) (ExpectedBalance balance)
$ "its actual balance is: " <> pretty realBalance
composeValidators ::
SuccessValidator
-> SuccessValidator
-> SuccessValidator
composeValidators val1 val2 gState updates =
val1 gState updates >> val2 gState updates
composeValidatorsList :: [SuccessValidator] -> SuccessValidator
composeValidatorsList = foldl' composeValidators expectAnySuccess
expectGasExhaustion :: ExecutorError -> Bool
expectGasExhaustion =
\case
EEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> True
_ -> False
expectMichelsonFailed :: (MichelsonFailed -> Bool) -> Address -> ExecutorError -> Bool
expectMichelsonFailed predicate addr =
\case
EEInterpreterFailed failedAddr (RuntimeFailure (mf, _)) ->
addr == failedAddr && predicate mf
_ -> False
initIS :: InternalState
initIS = InternalState
{ _isNow = dummyNow
, _isMaxSteps = dummyMaxSteps
, _isGState = initGState
, _isInterpreterLog = mempty
, _isExecutorResult = Nothing
, _isContractsNames = Map.empty
, _isSender = Nothing
}
integrationalTest ::
(Maybe ScenarioError -> res)
-> IntegrationalScenario
-> res
integrationalTest howToFail scenario =
howToFail $ leftToMaybe $ runExcept (runStateT scenario initIS)
validateResult ::
IntegrationalValidator
-> ExecutorResOrError
-> InternalState
-> IntegrationalScenarioM ()
validateResult validator result iState =
case (validator, result) of
(Left validateError, Left err)
| validateError err -> pass
(_, Left err) ->
doFail $ UnexpectedExecutorError (mkError err iState)
(Left _, Right _) ->
doFail $ ExpectingInterpreterToFail
(Right validateUpdates, Right ir)
| Left bad <- validateUpdates iState (_erGState ir) (_erUpdates ir) ->
doFail $ IncorrectUpdates bad (_erUpdates ir)
| otherwise -> pass
where
doFail = integrationalFail
mkError
:: ExecutorError -> InternalState -> IntegrationalExecutorError
mkError iErr is = case iErr of
EEUnknownContract addr -> EEUnknownContract $ addrToAddrName addr is
EEInterpreterFailed addr err ->
EEInterpreterFailed (addrToAddrName addr is) err
EEAlreadyOriginated addr cs ->
EEAlreadyOriginated (addrToAddrName addr is) cs
EEUnknownSender addr -> EEUnknownSender $ addrToAddrName addr is
EEUnknownManager addr -> EEUnknownManager $ addrToAddrName addr is
EENotEnoughFunds addr amount ->
EENotEnoughFunds (addrToAddrName addr is) amount
EEZeroTransaction addr ->
EEZeroTransaction (addrToAddrName addr is)
EEFailedToApplyUpdates err -> EEFailedToApplyUpdates err
EEIllTypedContract err -> EEIllTypedContract err
EEIllTypedStorage err -> EEIllTypedStorage err
EEIllTypedParameter err -> EEIllTypedParameter err
EEUnknownEntrypoint err -> EEUnknownEntrypoint err