module Michelson.Test.Integrational
(
TxData (..)
, genesisAddress
, genesisAddress1
, genesisAddress2
, genesisAddress3
, genesisAddress4
, genesisAddress5
, genesisAddress6
, IntegrationalValidator
, SuccessValidator
, IntegrationalScenarioM
, IntegrationalScenario
, ValidationError (..)
, integrationalTestExpectation
, integrationalTestProperty
, originate
, transfer
, validate
, setMaxSteps
, modifyNow
, setNow
, rewindTime
, withSender
, setChainId
, branchout
, (?-)
, offshoot
, composeValidators
, composeValidatorsList
, expectAnySuccess
, expectNoUpdates
, expectNoStorageUpdates
, expectStorageUpdate
, expectStorageUpdateConst
, expectBalance
, expectStorageConst
, 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 Test.Hspec (Expectation, expectationFailure)
import Test.QuickCheck (Property)
import Michelson.Interpret (InterpretError(..), 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 (ChainId, Mutez, Timestamp, timestampPlusSeconds, unsafeMkMutez)
data InternalState = InternalState
{ _isMaxSteps :: !RemainingSteps
, _isNow :: !Timestamp
, _isGState :: !GState
, _isOperations :: ![InterpreterOp]
, _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 (InterpreterError -> 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 (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
| UnexpectedUpdates (NonEmpty GStateUpdate)
| CustomValidationError 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 (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))
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 $
withExcept (ScenarioError emptyScenarioBranch) $
validateResult validator interpret iState
isOperations .= mempty
whenJust mUpdatedGState $ \newGState -> isGState .= newGState
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)
putOperation :: InterpreterOp -> IntegrationalScenarioM ()
putOperation op = isOperations <>= one op
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
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 _ =
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 :: 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 ScenarioError -> 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
IEZeroTransaction addr ->
IEZeroTransaction (addrToAddrName addr is)
IEFailedToApplyUpdates err -> IEFailedToApplyUpdates err
IEIllTypedContract err -> IEIllTypedContract err
IEIllTypedStorage err -> IEIllTypedStorage err
IEIllTypedParameter err -> IEIllTypedParameter err