module Michelson.Test.Integrational
(
TxData (..)
, genesisAddress
, genesisAddress1
, genesisAddress2
, genesisAddress3
, genesisAddress4
, genesisAddress5
, genesisAddress6
, IntegrationalValidator
, SuccessValidator
, IntegrationalScenarioM
, IntegrationalScenario
, ValidationError (..)
, integrationalTestExpectation
, integrationalTestProperty
, originate
, transfer
, validate
, setMaxSteps
, setNow
, withSender
, 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 Data.Map as Map (empty, insert, lookup)
import Fmt (Buildable(..), blockListF, pretty, (+|), (|+))
import Test.Hspec (Expectation, expectationFailure)
import Test.QuickCheck (Property)
import Michelson.Interpret (InterpretUntypedError(..), MichelsonFailed(..), RemainingSteps)
import Michelson.Runtime
(InterpreterError, InterpreterError'(..), InterpreterOp(..), InterpreterRes(..), interpreterPure)
import Michelson.Runtime.GState
import Michelson.Runtime.TxData
import Michelson.Test.Dummy
import Michelson.Test.Util (failedProp, succeededProp)
import Michelson.TypeCheck (TCError)
import Michelson.Untyped (Contract, OriginationOperation(..), Value, mkContractAddress)
import Tezos.Address (Address)
import Tezos.Core (Mutez, Timestamp)
data InternalState = InternalState
{ _isMaxSteps :: !RemainingSteps
, _isNow :: !Timestamp
, _isGState :: !GState
, _isOperations :: ![InterpreterOp]
, _isContractsNames :: !(Map Address Text)
, _isSender :: !(Maybe Address)
}
makeLenses ''InternalState
type IntegrationalValidator = Either (InterpreterError -> Bool) SuccessValidator
type SuccessValidator = (InternalState -> GState -> [GStateUpdate] -> Either ValidationError ())
type IntegrationalScenarioM = StateT InternalState (Except ValidationError)
data Validated = Validated
type IntegrationalScenario = IntegrationalScenarioM Validated
newtype ExpectedStorage = ExpectedStorage Value deriving (Show)
newtype ExpectedBalance = ExpectedBalance Mutez deriving (Show)
data AddressName = AddressName (Maybe Text) Address deriving (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 IntegrationalInterpreterError = InterpreterError' AddressName
data ValidationError
= UnexpectedInterpreterError IntegrationalInterpreterError
| UnexpectedTypeCheckError TCError
| ExpectingInterpreterToFail
| IncorrectUpdates ValidationError [GStateUpdate]
| IncorrectStorageUpdate AddressName Text
| InvalidStorage AddressName ExpectedStorage Text
| InvalidBalance AddressName ExpectedBalance Text
| CustomError Text
deriving (Show)
instance Buildable ValidationError where
build (UnexpectedInterpreterError 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 (InvalidBalance addr (ExpectedBalance expected) msg) =
"Expected " +| addr |+ " to have balance " +| expected |+ ", but " +| msg |+ ""
build (CustomError msg) = pretty msg
instance Exception ValidationError where
displayException = pretty
integrationalTestExpectation :: IntegrationalScenario -> Expectation
integrationalTestExpectation =
integrationalTest (maybe pass (expectationFailure . pretty))
integrationalTestProperty :: IntegrationalScenario -> Property
integrationalTestProperty =
integrationalTest (maybe succeededProp (failedProp . pretty))
originate :: Contract -> Text -> Value -> Mutez -> IntegrationalScenarioM Address
originate contract contractName value balance = do
address <- mkContractAddress origination <$ putOperation originateOp
isContractsNames %= (insert address contractName)
pure address
where
origination = (dummyOrigination value contract) {ooBalance = balance}
originateOp = OriginateOp origination
transfer :: TxData -> Address -> IntegrationalScenarioM ()
transfer txData destination = do
mSender <- use isSender
let txData' = maybe id (set tdSenderAddressL) mSender txData
putOperation (TransferOp destination txData')
validate :: IntegrationalValidator -> IntegrationalScenario
validate validator = Validated <$ do
now <- use isNow
maxSteps <- use isMaxSteps
gState <- use isGState
ops <- use isOperations
iState <- get
let interpret = interpreterPure now maxSteps gState ops
mUpdatedGState <- lift $ validateResult validator interpret iState
isOperations .= mempty
whenJust mUpdatedGState $ \newGState -> isGState .= newGState
setNow :: Timestamp -> IntegrationalScenarioM ()
setNow = assign isNow
setMaxSteps :: RemainingSteps -> IntegrationalScenarioM ()
setMaxSteps = assign isMaxSteps
withSender :: Address -> IntegrationalScenarioM a -> IntegrationalScenarioM a
withSender addr scenario = do
prevSender <- use isSender
isSender ?= addr
scenario <* (isSender .= prevSender)
putOperation :: InterpreterOp -> IntegrationalScenarioM ()
putOperation op = isOperations <>= one op
expectAnySuccess :: SuccessValidator
expectAnySuccess _ _ _ = pass
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 gs _ =
case gsAddresses gs ^. at addr of
Just (ASContract cs)
| csStorage cs == expected -> pass
| otherwise ->
Left $ intro $ "its actual storage is: " <> (pretty $ csStorage cs)
Just (ASSimple {}) ->
Left $ intro $ "it's a simple address"
Nothing -> Left $ intro $ "it's unknown"
where
intro = InvalidStorage (addrToAddrName addr is) (ExpectedStorage expected)
expectBalance :: Address -> Mutez -> SuccessValidator
expectBalance addr balance is gs _ =
case gsAddresses gs ^. at addr of
Nothing ->
Left $
InvalidBalance (addrToAddrName addr is) (ExpectedBalance balance) "it's unknown"
Just (asBalance -> realBalance)
| realBalance == balance -> pass
| otherwise ->
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 :: InterpreterError -> Bool
expectGasExhaustion =
\case
IEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> True
_ -> False
expectMichelsonFailed :: (MichelsonFailed -> Bool) -> Address -> InterpreterError -> Bool
expectMichelsonFailed predicate addr =
\case
IEInterpreterFailed failedAddr (RuntimeFailure (mf, _)) ->
addr == failedAddr && predicate mf
_ -> False
initIS :: InternalState
initIS = InternalState
{ _isNow = dummyNow
, _isMaxSteps = dummyMaxSteps
, _isGState = initGState
, _isOperations = mempty
, _isContractsNames = Map.empty
, _isSender = Nothing
}
integrationalTest ::
(Maybe ValidationError -> res)
-> IntegrationalScenario
-> res
integrationalTest howToFail scenario =
howToFail $ leftToMaybe $ runExcept (runStateT scenario initIS)
validateResult ::
IntegrationalValidator
-> Either InterpreterError InterpreterRes
-> InternalState
-> Except ValidationError (Maybe GState)
validateResult validator result iState =
case (validator, result) of
(Left validateError, Left err)
| validateError err -> pure Nothing
(_, Left err) ->
doFail $ UnexpectedInterpreterError $ mkError err iState
(Left _, Right _) ->
doFail $ ExpectingInterpreterToFail
(Right validateUpdates, Right ir)
| Left bad <- validateUpdates iState (_irGState ir) (_irUpdates ir) ->
doFail $ IncorrectUpdates bad (_irUpdates ir)
| otherwise -> pure $ Just $ _irGState ir
where
doFail = throwError
mkError
:: InterpreterError -> InternalState -> IntegrationalInterpreterError
mkError iErr is = case iErr of
IEUnknownContract addr -> IEUnknownContract $ addrToAddrName addr is
IEInterpreterFailed addr err ->
IEInterpreterFailed (addrToAddrName addr is) err
IEAlreadyOriginated addr cs ->
IEAlreadyOriginated (addrToAddrName addr is) cs
IEUnknownSender addr -> IEUnknownSender $ addrToAddrName addr is
IEUnknownManager addr -> IEUnknownManager $ addrToAddrName addr is
IENotEnoughFunds addr amount ->
IENotEnoughFunds (addrToAddrName addr is) amount
IEFailedToApplyUpdates err -> IEFailedToApplyUpdates err
IEIllTypedContract err -> IEIllTypedContract err