{-# Language DataKinds #-}
{-# Language ImplicitParams #-}

module EVM.UnitTest where

import Prelude hiding (Word)

import EVM hiding (Unknown, path)
import EVM.ABI
import EVM.Concrete
import EVM.SMT
import EVM.Dapp
import EVM.Debug (srcMapCodePos)
import EVM.Exec
import EVM.Expr (litAddr, readStorage', simplify)
import EVM.Format
import EVM.Solidity
import qualified EVM.SymExec as SymExec
import EVM.SymExec (defaultVeriOpts, symCalldata, verify, isQed, extractCex, runExpr, subModel, VeriOpts)
import EVM.Types hiding (Failure)
import EVM.Transaction (initTx)
import EVM.RLP
import qualified EVM.Facts     as Facts
import qualified EVM.Facts.Git as Git
import qualified EVM.Fetch     as Fetch
import qualified EVM.Expr      as Expr

import qualified EVM.FeeSchedule as FeeSchedule

import EVM.Stepper (Stepper, interpret)
import qualified EVM.Stepper as Stepper
import qualified Control.Monad.Operational as Operational

import Control.Lens hiding (Indexed, elements, List, passing)
import Control.Monad.State.Strict hiding (state)
import qualified Control.Monad.State.Strict as State

import Control.Monad.Par.Class (spawn_)
import Control.Monad.Par.IO (runParIO)

import qualified Data.ByteString.Lazy as BSLazy
import Data.Binary.Get    (runGet)
import Data.ByteString    (ByteString)
import Data.Decimal       (DecimalRaw(..))
import Data.Either        (isRight)
import Data.Foldable      (toList)
import Data.Map           (Map)
import Data.Maybe         (fromMaybe, catMaybes, fromJust, isJust, fromMaybe, mapMaybe, isNothing)
import Data.Text          (isPrefixOf, stripSuffix, intercalate, Text, pack, unpack)
import Data.Word          (Word32, Word64)
import Data.Text.Encoding (encodeUtf8)
import System.Environment (lookupEnv)
import System.IO          (hFlush, stdout)
import GHC.Natural

import qualified Control.Monad.Par.Class as Par
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text

import Data.MultiSet (MultiSet)
import qualified Data.MultiSet as MultiSet

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Vector (Vector)
import qualified Data.Vector as Vector

import Test.QuickCheck hiding (verbose)

data UnitTestOptions = UnitTestOptions
  { UnitTestOptions -> RpcInfo
rpcInfo     :: Fetch.RpcInfo
  , UnitTestOptions -> SolverGroup
solvers     :: SolverGroup
  , UnitTestOptions -> Maybe Int
verbose     :: Maybe Int
  , UnitTestOptions -> Maybe Integer
maxIter     :: Maybe Integer
  , UnitTestOptions -> Maybe Integer
askSmtIters :: Maybe Integer
  , UnitTestOptions -> Bool
smtDebug    :: Bool
  , UnitTestOptions -> Maybe Int
maxDepth    :: Maybe Int
  , UnitTestOptions -> Maybe Natural
smtTimeout  :: Maybe Natural
  , UnitTestOptions -> Maybe Text
solver      :: Maybe Text
  , UnitTestOptions -> Maybe Text
covMatch    :: Maybe Text
  , UnitTestOptions -> Text
match       :: Text
  , UnitTestOptions -> Int
fuzzRuns    :: Int
  , UnitTestOptions -> Maybe (Text, ByteString)
replay      :: Maybe (Text, BSLazy.ByteString)
  , UnitTestOptions -> VM -> VM
vmModifier  :: VM -> VM
  , UnitTestOptions -> DappInfo
dapp        :: DappInfo
  , UnitTestOptions -> TestVMParams
testParams  :: TestVMParams
  , UnitTestOptions -> Bool
ffiAllowed  :: Bool
  }

data TestVMParams = TestVMParams
  { TestVMParams -> Addr
testAddress       :: Addr
  , TestVMParams -> Addr
testCaller        :: Addr
  , TestVMParams -> Addr
testOrigin        :: Addr
  , TestVMParams -> Word64
testGasCreate     :: Word64
  , TestVMParams -> Word64
testGasCall       :: Word64
  , TestVMParams -> W256
testBaseFee       :: W256
  , TestVMParams -> W256
testPriorityFee   :: W256
  , TestVMParams -> W256
testBalanceCreate :: W256
  , TestVMParams -> Addr
testCoinbase      :: Addr
  , TestVMParams -> W256
testNumber        :: W256
  , TestVMParams -> W256
testTimestamp     :: W256
  , TestVMParams -> Word64
testGaslimit      :: Word64
  , TestVMParams -> W256
testGasprice      :: W256
  , TestVMParams -> W256
testMaxCodeSize   :: W256
  , TestVMParams -> W256
testPrevrandao    :: W256
  , TestVMParams -> W256
testChainId       :: W256
  }

defaultGasForCreating :: Word64
defaultGasForCreating :: Word64
defaultGasForCreating = Word64
0xffffffffffff

defaultGasForInvoking :: Word64
defaultGasForInvoking :: Word64
defaultGasForInvoking = Word64
0xffffffffffff

defaultBalanceForTestContract :: W256
defaultBalanceForTestContract :: W256
defaultBalanceForTestContract = W256
0xffffffffffffffffffffffff

defaultMaxCodeSize :: W256
defaultMaxCodeSize :: W256
defaultMaxCodeSize = W256
0xffffffff

type ABIMethod = Text


-- | Generate VeriOpts from UnitTestOptions
makeVeriOpts :: UnitTestOptions -> VeriOpts
makeVeriOpts :: UnitTestOptions -> VeriOpts
makeVeriOpts UnitTestOptions
opts =
   VeriOpts
defaultVeriOpts { debug :: Bool
SymExec.debug = UnitTestOptions -> Bool
smtDebug UnitTestOptions
opts
                   , maxIter :: Maybe Integer
SymExec.maxIter = UnitTestOptions -> Maybe Integer
maxIter UnitTestOptions
opts
                   , askSmtIters :: Maybe Integer
SymExec.askSmtIters = UnitTestOptions -> Maybe Integer
askSmtIters UnitTestOptions
opts
                   , rpcInfo :: RpcInfo
SymExec.rpcInfo = UnitTestOptions -> RpcInfo
rpcInfo UnitTestOptions
opts
                   }

-- | Top level CLI endpoint for dapp-test
dappTest :: UnitTestOptions -> String -> Maybe String -> IO Bool
dappTest :: UnitTestOptions -> [Char] -> Maybe [Char] -> IO Bool
dappTest UnitTestOptions
opts [Char]
solcFile Maybe [Char]
cache' = do
  Maybe (Map Text SolcContract, SourceCache)
out <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe (Map Text SolcContract, SourceCache))
readSolc [Char]
solcFile
  case Maybe (Map Text SolcContract, SourceCache)
out of
    Just (Map Text SolcContract
contractMap, SourceCache
_) -> do
      let unitTests :: [(Text, [(Test, [AbiType])])]
unitTests = Text -> [SolcContract] -> [(Text, [(Test, [AbiType])])]
findUnitTests (UnitTestOptions -> Text
EVM.UnitTest.match UnitTestOptions
opts) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map Text SolcContract
contractMap
      [(Bool, VM)]
results <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (UnitTestOptions
-> Map Text SolcContract
-> (Text, [(Test, [AbiType])])
-> IO [(Bool, VM)]
runUnitTestContract UnitTestOptions
opts Map Text SolcContract
contractMap) [(Text, [(Test, [AbiType])])]
unitTests
      let ([Bool]
passing, [VM]
vms) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, VM)]
results
      case Maybe [Char]
cache' of
        Maybe [Char]
Nothing ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just [Char]
path ->
          -- merge all of the post-vm caches and save into the state
          let
            evmcache :: Cache
evmcache = forall a. Monoid a => [a] -> a
mconcat [forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' VM Cache
EVM.cache VM
vm | VM
vm <- [VM]
vms]
          in
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RepoAt -> Set Fact -> IO ()
Git.saveFacts ([Char] -> RepoAt
Git.RepoAt [Char]
path) (Cache -> Set Fact
Facts.cacheFacts Cache
evmcache)

      if forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
passing
         then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
         else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Maybe (Map Text SolcContract, SourceCache)
Nothing ->
      forall a. HasCallStack => [Char] -> a
error ([Char]
"Failed to read Solidity JSON for `" forall a. [a] -> [a] -> [a]
++ [Char]
solcFile forall a. [a] -> [a] -> [a]
++ [Char]
"'")


-- | Assuming a constructor is loaded, this stepper will run the constructor
-- to create the test contract, give it an initial balance, and run `setUp()'.
initializeUnitTest :: UnitTestOptions -> SolcContract -> Stepper ()
initializeUnitTest :: UnitTestOptions -> SolcContract -> Stepper ()
initializeUnitTest UnitTestOptions { Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
.. } SolcContract
theContract = do

  let addr :: Addr
addr = TestVMParams -> Addr
testAddress TestVMParams
testParams

  forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ do
    -- Maybe modify the initial VM, e.g. to load library code
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify VM -> VM
vmModifier
    -- Make a trace entry for running the constructor
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
"constructor")

  -- Constructor is loaded; run until it returns code
  forall (f :: * -> *) a. Functor f => f a -> f ()
void Stepper (Either Error (Expr 'Buf))
Stepper.execFully

  forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ do
    -- Give a balance to the test target
    Lens' VM Env
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Env (Map Addr Contract)
contracts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Addr
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Contract W256
balance forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= TestVMParams -> W256
testBalanceCreate TestVMParams
testParams

    -- call setUp(), if it exists, to initialize the test contract
    let theAbi :: Map Word32 Method
theAbi = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SolcContract (Map Word32 Method)
abiMap SolcContract
theContract
        setUp :: Word32
setUp  = ByteString -> Word32
abiKeccak (Text -> ByteString
encodeUtf8 Text
"setUp()")

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word32
setUp Map Word32 Method
theAbi)) forall a b. (a -> b) -> a -> b
$ do
      TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams (forall a b. a -> Either a b
Left (Text
"setUp()", AbiValue
emptyAbi))
      EVM ()
popTrace
      TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
"setUp()")

  -- Let `setUp()' run to completion
  Either Error (Expr 'Buf)
res <- Stepper (Either Error (Expr 'Buf))
Stepper.execFully
  forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ case Either Error (Expr 'Buf)
res of
    Left Error
e -> TraceData -> EVM ()
pushTrace (Error -> TraceData
ErrorTrace Error
e)
    Either Error (Expr 'Buf)
_ -> EVM ()
popTrace

-- | Assuming a test contract is loaded and initialized, this stepper
-- will run the specified test method and return whether it succeeded.
runUnitTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool
runUnitTest :: UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
a Text
method AbiValue
args = do
  Bool
x <- UnitTestOptions -> Text -> AbiValue -> Stepper Bool
execTestStepper UnitTestOptions
a Text
method AbiValue
args
  UnitTestOptions -> Text -> Bool -> Stepper Bool
checkFailures UnitTestOptions
a Text
method Bool
x

execTestStepper :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool
execTestStepper :: UnitTestOptions -> Text -> AbiValue -> Stepper Bool
execTestStepper UnitTestOptions { Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
.. } Text
methodName' AbiValue
method = do
  -- Set up the call to the test method
  forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ do
    TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams (forall a b. a -> Either a b
Left (Text
methodName', AbiValue
method))
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
methodName')
  -- Try running the test method
  Stepper (Either Error (Expr 'Buf))
Stepper.execFully forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
     -- If we failed, put the error in the trace.
    Left Error
e -> forall a. EVM a -> Stepper a
Stepper.evm (TraceData -> EVM ()
pushTrace (Error -> TraceData
ErrorTrace Error
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EVM ()
popTrace) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Either Error (Expr 'Buf)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

exploreStep :: UnitTestOptions -> ByteString -> Stepper Bool
exploreStep :: UnitTestOptions -> ByteString -> Stepper Bool
exploreStep UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} ByteString
bs = do
  forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ do
    Map Addr Contract
cs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' VM Env
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Env (Map Addr Contract)
contracts)
    TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams (forall a b. b -> Either a b
Right ByteString
bs)
    let (Method [(Text, AbiType)]
_ [(Text, AbiType)]
inputs Text
sig Text
_ Mutability
_) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"unknown abi call") forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a b. (Integral a, Num b) => a -> b
num forall a b. (a -> b) -> a -> b
$ ByteString -> W256
word forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
bs) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' DappInfo (Map Word32 Method)
dappAbiMap DappInfo
dapp)
        types :: [AbiType]
types = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, AbiType)]
inputs
    let ?context = DappInfo -> Map Addr Contract -> DappContext
DappContext DappInfo
dapp Map Addr Contract
cs
    Contract
this <- forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"unknown target") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' VM Env
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Env (Map Addr Contract)
contracts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (TestVMParams -> Addr
testAddress TestVMParams
testParams)))
    let name :: Text
name = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text -> Text
contractNamePart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SolcContract Text
contractName) forall a b. (a -> b) -> a -> b
$ ContractCode -> DappInfo -> Maybe SolcContract
lookupCode (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract ContractCode
contractcode Contract
this) DappInfo
dapp
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace (Text
name forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
sig forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"," (([Char] -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AbiType]
types) forall a. Semigroup a => a -> a -> a
<> Text
")" forall a. Semigroup a => a -> a -> a
<> (?context::DappContext) => [AbiType] -> Expr 'Buf -> Text
showCall [AbiType]
types (ByteString -> Expr 'Buf
ConcreteBuf ByteString
bs)))
  -- Try running the test method
  Stepper (Either Error (Expr 'Buf))
Stepper.execFully forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
     -- If we failed, put the error in the trace.
    Left Error
e -> forall a. EVM a -> Stepper a
Stepper.evm (TraceData -> EVM ()
pushTrace (Error -> TraceData
ErrorTrace Error
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EVM ()
popTrace) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Either Error (Expr 'Buf)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

checkFailures :: UnitTestOptions -> ABIMethod -> Bool -> Stepper Bool
checkFailures :: UnitTestOptions -> Text -> Bool -> Stepper Bool
checkFailures UnitTestOptions { Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
.. } Text
method Bool
bailed = do
   -- Decide whether the test is supposed to fail or succeed
  let shouldFail :: Bool
shouldFail = Text
"testFail" Text -> Text -> Bool
`isPrefixOf` Text
method
  if Bool
bailed then
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
shouldFail
  else do
    -- Ask whether any assertions failed
    forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ do
      EVM ()
popTrace
      TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (Text
"failed()", AbiValue
emptyAbi)
    Either Error (Expr 'Buf)
res <- Stepper (Either Error (Expr 'Buf))
Stepper.execFully
    case Either Error (Expr 'Buf)
res of
      Right (ConcreteBuf ByteString
r) ->
        let failed :: Bool
failed = case AbiType -> ByteString -> AbiValue
decodeAbiValue AbiType
AbiBoolType (ByteString -> ByteString
BSLazy.fromStrict ByteString
r) of
              AbiBool Bool
f -> Bool
f
              AbiValue
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"fix me with better types"
        in forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
shouldFail forall a. Eq a => a -> a -> Bool
== Bool
failed)
      Either Error (Expr 'Buf)
c -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"internal error: unexpected failure code: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Either Error (Expr 'Buf)
c

-- | Randomly generates the calldata arguments and runs the test
fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property
fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property
fuzzTest opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} Text
sig [AbiType]
types VM
vm = forall prop a.
Testable prop =>
Gen a -> (a -> [Char]) -> (a -> prop) -> Property
forAllShow (AbiType -> Gen AbiValue
genAbiValue (Vector AbiType -> AbiType
AbiTupleType forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList [AbiType]
types)) (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteStringS
ByteStringS forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbiValue -> ByteString
encodeAbiValue)
  forall a b. (a -> b) -> a -> b
$ \AbiValue
args -> forall prop. Testable prop => IO prop -> Property
ioProperty forall a b. (a -> b) -> a -> b
$
    forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall a. Fetcher -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) (UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts Text
sig AbiValue
args)) VM
vm

tick :: Text -> IO ()
tick :: Text -> IO ()
tick Text
x = Text -> IO ()
Text.putStr Text
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout

-- | This is like an unresolved source mapping.
data OpLocation = OpLocation
  { OpLocation -> Contract
srcContract :: Contract
  , OpLocation -> Int
srcOpIx :: Int
  } deriving (Int -> OpLocation -> ShowS
[OpLocation] -> ShowS
OpLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [OpLocation] -> ShowS
$cshowList :: [OpLocation] -> ShowS
show :: OpLocation -> [Char]
$cshow :: OpLocation -> [Char]
showsPrec :: Int -> OpLocation -> ShowS
$cshowsPrec :: Int -> OpLocation -> ShowS
Show)

instance Eq OpLocation where
  == :: OpLocation -> OpLocation -> Bool
(==) (OpLocation Contract
a Int
b) (OpLocation Contract
a' Int
b') = Int
b forall a. Eq a => a -> a -> Bool
== Int
b' Bool -> Bool -> Bool
&& forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract ContractCode
contractcode Contract
a forall a. Eq a => a -> a -> Bool
== forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract ContractCode
contractcode Contract
a'

instance Ord OpLocation where
  compare :: OpLocation -> OpLocation -> Ordering
compare (OpLocation Contract
a Int
b) (OpLocation Contract
a' Int
b') = forall a. Ord a => a -> a -> Ordering
compare (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract ContractCode
contractcode Contract
a, Int
b) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract ContractCode
contractcode Contract
a', Int
b')

srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap
srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap
srcMapForOpLocation DappInfo
dapp (OpLocation Contract
contr Int
opIx) = DappInfo -> Contract -> Int -> Maybe SrcMap
srcMap DappInfo
dapp Contract
contr Int
opIx

type CoverageState = (VM, MultiSet OpLocation)

currentOpLocation :: VM -> OpLocation
currentOpLocation :: VM -> OpLocation
currentOpLocation VM
vm =
  case VM -> Maybe Contract
currentContract VM
vm of
    Maybe Contract
Nothing ->
      forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: why no contract?"
    Just Contract
c ->
      Contract -> Int -> OpLocation
OpLocation
        Contract
c
        (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: op ix") (VM -> Maybe Int
vmOpIx VM
vm))

execWithCoverage :: StateT CoverageState IO VMResult
execWithCoverage :: StateT CoverageState IO VMResult
execWithCoverage = do VM
_ <- StateT CoverageState IO VM
runWithCoverage
                      forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' VM (Maybe VMResult)
result)

runWithCoverage :: StateT CoverageState IO VM
runWithCoverage :: StateT CoverageState IO VM
runWithCoverage = do
  -- This is just like `exec` except for every instruction evaluated,
  -- we also increment a counter indexed by the current code location.
  VM
vm0 <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall s t a b. Field1 s t a b => Lens s t a b
_1
  case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' VM (Maybe VMResult)
result VM
vm0 of
    Maybe VMResult
Nothing -> do
      VM
vm1 <- forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom forall s t a b. Field1 s t a b => Lens s t a b
_1 (forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
State.state (forall s a. State s a -> s -> (a, s)
runState EVM ()
exec1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *). MonadState s m => m s
get)
      forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom forall s t a b. Field2 s t a b => Lens s t a b
_2 (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Ord a => a -> MultiSet a -> MultiSet a
MultiSet.insert (VM -> OpLocation
currentOpLocation VM
vm1)))
      StateT CoverageState IO VM
runWithCoverage
    Just VMResult
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure VM
vm0


interpretWithCoverage
  :: UnitTestOptions
  -> Stepper a
  -> StateT CoverageState IO a
interpretWithCoverage :: forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} =
  forall a. ProgramView Action a -> StateT CoverageState IO a
eval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
Operational.view

  where
    eval
      :: Operational.ProgramView Stepper.Action a
      -> StateT CoverageState IO a

    eval :: forall a. ProgramView Action a -> StateT CoverageState IO a
eval (Operational.Return a
x) =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

    eval (Action b
action Operational.:>>= b -> ProgramT Action Identity a
k) =
      case Action b
action of
        Action b
Stepper.Exec ->
          StateT CoverageState IO VMResult
execWithCoverage forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT Action Identity a
k
        Action b
Stepper.Run ->
          StateT CoverageState IO VM
runWithCoverage forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT Action Identity a
k
        Stepper.Wait Query
q ->
          do EVM ()
m <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) Query
q)
             forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom forall s t a b. Field1 s t a b => Lens s t a b
_1 (forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
State.state (forall s a. State s a -> s -> (a, s)
runState EVM ()
m)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts (b -> ProgramT Action Identity a
k ())
        Stepper.Ask Choose
_ ->
          forall a. HasCallStack => [Char] -> a
error [Char]
"cannot make choice in this interpreter"
        Stepper.IOAct StateT VM IO b
q ->
          forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom forall s t a b. Field1 s t a b => Lens s t a b
_1 (forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT VM IO b
q)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT Action Identity a
k
        Stepper.EVM EVM b
m ->
          forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom forall s t a b. Field1 s t a b => Lens s t a b
_1 (forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
State.state (forall s a. State s a -> s -> (a, s)
runState EVM b
m)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT Action Identity a
k

coverageReport
  :: DappInfo
  -> MultiSet SrcMap
  -> Map Text (Vector (Int, ByteString))
coverageReport :: DappInfo -> MultiSet SrcMap -> Map Text (Vector (Int, ByteString))
coverageReport DappInfo
dapp MultiSet SrcMap
cov =
  let
    sources :: SourceCache
    sources :: SourceCache
sources = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' DappInfo SourceCache
dappSources DappInfo
dapp

    allPositions :: Set (Text, Int)
    allPositions :: Set (Text, Int)
allPositions =
      ( forall a. Ord a => [a] -> Set a
Set.fromList
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SourceCache -> SrcMap -> Maybe (Text, Int)
srcMapCodePos SourceCache
sources)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
      forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        ( forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' DappInfo (Map Text SolcContract)
dappSolcByName DappInfo
dapp
        forall a b. a -> (a -> b) -> b
& forall k a. Map k a -> [a]
Map.elems
        forall a b. a -> (a -> b) -> b
& forall a b. (a -> b) -> [a] -> [b]
map (\SolcContract
x -> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SolcContract (Seq SrcMap)
runtimeSrcmap SolcContract
x forall a. Semigroup a => a -> a -> a
<> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SolcContract (Seq SrcMap)
creationSrcmap SolcContract
x)
        )
      )

    srcMapCov :: MultiSet (Text, Int)
    srcMapCov :: MultiSet (Text, Int)
srcMapCov = forall b a. Ord b => (a -> Maybe b) -> MultiSet a -> MultiSet b
MultiSet.mapMaybe (SourceCache -> SrcMap -> Maybe (Text, Int)
srcMapCodePos SourceCache
sources) MultiSet SrcMap
cov

    linesByName :: Map Text (Vector ByteString)
    linesByName :: Map Text (Vector ByteString)
linesByName =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
          (\(Text
name, ByteString
_) Vector ByteString
lines' -> (Text
name, Vector ByteString
lines'))
          (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SourceCache [(Text, ByteString)]
sourceFiles SourceCache
sources)
          (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SourceCache [Vector ByteString]
sourceLines SourceCache
sources)

    f :: Text -> Vector ByteString -> Vector (Int, ByteString)
    f :: Text -> Vector ByteString -> Vector (Int, ByteString)
f Text
name =
      forall a b. (Int -> a -> b) -> Vector a -> Vector b
Vector.imap
        (\Int
i ByteString
bs ->
           let
             n :: Int
n =
               if forall a. Ord a => a -> Set a -> Bool
Set.member (Text
name, Int
i forall a. Num a => a -> a -> a
+ Int
1) Set (Text, Int)
allPositions
               then forall a. Ord a => a -> MultiSet a -> Int
MultiSet.occur (Text
name, Int
i forall a. Num a => a -> a -> a
+ Int
1) MultiSet (Text, Int)
srcMapCov
               else -Int
1
           in (Int
n, ByteString
bs))
  in
    forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Text -> Vector ByteString -> Vector (Int, ByteString)
f Map Text (Vector ByteString)
linesByName

coverageForUnitTestContract
  :: UnitTestOptions
  -> Map Text SolcContract
  -> SourceCache
  -> (Text, [(Test, [AbiType])])
  -> IO (MultiSet SrcMap)
coverageForUnitTestContract :: UnitTestOptions
-> Map Text SolcContract
-> SourceCache
-> (Text, [(Test, [AbiType])])
-> IO (MultiSet SrcMap)
coverageForUnitTestContract
  opts :: UnitTestOptions
opts@(UnitTestOptions {Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..}) Map Text SolcContract
contractMap SourceCache
_ (Text
name, [(Test, [AbiType])]
testNames) = do

  -- Look for the wanted contract by name from the Solidity info
  case forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
name) Map Text SolcContract
contractMap of
    Maybe SolcContract
Nothing ->
      -- Fail if there's no such contract
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Contract " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
name forall a. [a] -> [a] -> [a]
++ [Char]
" not found"

    Just SolcContract
theContract -> do
      -- Construct the initial VM and begin the contract's constructor
      let vm0 :: VM
vm0 = UnitTestOptions -> SolcContract -> VM
initialUnitTestVm UnitTestOptions
opts SolcContract
theContract
      (VM
vm1, MultiSet OpLocation
cov1) <-
        forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
          (forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts
            (Text -> Stepper ()
Stepper.enter Text
name forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UnitTestOptions -> SolcContract -> Stepper ()
initializeUnitTest UnitTestOptions
opts SolcContract
theContract))
          (VM
vm0, forall a. Monoid a => a
mempty)

      -- Define the thread spawner for test cases
      let
        runOne' :: (Test, [AbiType]) -> ParIO (IVar (MultiSet OpLocation))
runOne' (Test
test, [AbiType]
_) = forall (future :: * -> *) (m :: * -> *) a.
ParFuture future m =>
m a -> m (future a)
spawn_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          (Bool
_, (VM
_, MultiSet OpLocation
cov)) <-
            forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
              (forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts (UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts (Test -> Text
extractSig Test
test) AbiValue
emptyAbi))
              (VM
vm1, forall a. Monoid a => a
mempty)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure MultiSet OpLocation
cov
      -- Run all the test cases in parallel and gather their coverages
      [MultiSet OpLocation]
covs <-
        forall a. ParIO a -> IO a
runParIO (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Test, [AbiType]) -> ParIO (IVar (MultiSet OpLocation))
runOne' [(Test, [AbiType])]
testNames forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (future :: * -> *) (m :: * -> *) a.
ParFuture future m =>
future a -> m a
Par.get)

      -- Sum up all the coverage counts
      let cov2 :: MultiSet OpLocation
cov2 = forall a. Ord a => [MultiSet a] -> MultiSet a
MultiSet.unions (MultiSet OpLocation
cov1 forall a. a -> [a] -> [a]
: [MultiSet OpLocation]
covs)

      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall b a. Ord b => (a -> Maybe b) -> MultiSet a -> MultiSet b
MultiSet.mapMaybe (DappInfo -> OpLocation -> Maybe SrcMap
srcMapForOpLocation DappInfo
dapp) MultiSet OpLocation
cov2)

runUnitTestContract
  :: UnitTestOptions
  -> Map Text SolcContract
  -> (Text, [(Test, [AbiType])])
  -> IO [(Bool, VM)]
runUnitTestContract :: UnitTestOptions
-> Map Text SolcContract
-> (Text, [(Test, [AbiType])])
-> IO [(Bool, VM)]
runUnitTestContract
  opts :: UnitTestOptions
opts@(UnitTestOptions {Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..}) Map Text SolcContract
contractMap (Text
name, [(Test, [AbiType])]
testSigs) = do

  -- Print a header
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Running " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Test, [AbiType])]
testSigs) forall a. [a] -> [a] -> [a]
++ [Char]
" tests for "
    forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
name

  -- Look for the wanted contract by name from the Solidity info
  case forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
name) Map Text SolcContract
contractMap of
    Maybe SolcContract
Nothing ->
      -- Fail if there's no such contract
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Contract " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
name forall a. [a] -> [a] -> [a]
++ [Char]
" not found"

    Just SolcContract
theContract -> do
      -- Construct the initial VM and begin the contract's constructor
      let vm0 :: VM
vm0 = UnitTestOptions -> SolcContract -> VM
initialUnitTestVm UnitTestOptions
opts SolcContract
theContract
      VM
vm1 <-
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
          (forall a. Fetcher -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo)
            (Text -> Stepper ()
Stepper.enter Text
name forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UnitTestOptions -> SolcContract -> Stepper ()
initializeUnitTest UnitTestOptions
opts SolcContract
theContract))
          VM
vm0

      case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' VM (Maybe VMResult)
result VM
vm1 of
        Maybe VMResult
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: setUp() did not end with a result"
        Just (VMFailure Error
_) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
Text.putStrLn Text
"\x1b[31m[BAIL]\x1b[0m setUp() "
          Text -> IO ()
tick Text
"\n"
          Text -> IO ()
tick ([Char] -> Text
Data.Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm1 UnitTestOptions
opts Text
"setUp()")
          forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Bool
False, VM
vm1)]
        Just (VMSuccess Expr 'Buf
_) -> do
          let

            runCache :: ([(Either Text Text, VM)], VM) -> (Test, [AbiType])
                        -> IO ([(Either Text Text, VM)], VM)
            runCache :: ([(Either Text Text, VM)], VM)
-> (Test, [AbiType]) -> IO ([(Either Text Text, VM)], VM)
runCache ([(Either Text Text, VM)]
results, VM
vm) (Test
test, [AbiType]
types) = do
              (Text
t, Either Text Text
r, VM
vm') <- UnitTestOptions
-> VM -> (Test, [AbiType]) -> IO (Text, Either Text Text, VM)
runTest UnitTestOptions
opts VM
vm (Test
test, [AbiType]
types)
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
t
              let vmCached :: VM
vmCached = VM
vm forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' VM Cache
cache (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' VM Cache
cache VM
vm')
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Either Text Text
r, VM
vm')forall a. a -> [a] -> [a]
: [(Either Text Text, VM)]
results), VM
vmCached)

          -- Run all the test cases and print their status updates,
          -- accumulating the vm cache throughout
          ([(Either Text Text, VM)]
details, VM
_) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(Either Text Text, VM)], VM)
-> (Test, [AbiType]) -> IO ([(Either Text Text, VM)], VM)
runCache ([], VM
vm1) [(Test, [AbiType])]
testSigs

          let running :: [Text]
running = [Text
x | (Right Text
x, VM
_) <- [(Either Text Text, VM)]
details]
          let bailing :: [Text]
bailing = [Text
x | (Left  Text
x, VM
_) <- [(Either Text Text, VM)]
details]

          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            Text -> IO ()
tick Text
"\n"
            Text -> IO ()
tick ([Text] -> Text
Text.unlines (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) [Text]
running))
            Text -> IO ()
tick ([Text] -> Text
Text.unlines [Text]
bailing)

          forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a b. Either a b -> Bool
isRight Either Text Text
r, VM
vm) | (Either Text Text
r, VM
vm) <- [(Either Text Text, VM)]
details]


runTest :: UnitTestOptions -> VM -> (Test, [AbiType]) -> IO (Text, Either Text Text, VM)
runTest :: UnitTestOptions
-> VM -> (Test, [AbiType]) -> IO (Text, Either Text Text, VM)
runTest opts :: UnitTestOptions
opts@UnitTestOptions{} VM
vm (ConcreteTest Text
testName, []) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ UnitTestOptions
-> VM -> Text -> AbiValue -> IO (Text, Either Text Text, VM)
runOne UnitTestOptions
opts VM
vm Text
testName AbiValue
emptyAbi
runTest opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} VM
vm (ConcreteTest Text
testName, [AbiType]
types) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case Maybe (Text, ByteString)
replay of
  Maybe (Text, ByteString)
Nothing ->
    UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
fuzzRun UnitTestOptions
opts VM
vm Text
testName [AbiType]
types
  Just (Text
sig, ByteString
callData) ->
    if Text
sig forall a. Eq a => a -> a -> Bool
== Text
testName
    then UnitTestOptions
-> VM -> Text -> AbiValue -> IO (Text, Either Text Text, VM)
runOne UnitTestOptions
opts VM
vm Text
testName forall a b. (a -> b) -> a -> b
$
      AbiType -> ByteString -> AbiValue
decodeAbiValue (Vector AbiType -> AbiType
AbiTupleType (forall a. [a] -> Vector a
Vector.fromList [AbiType]
types)) ByteString
callData
    else UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
fuzzRun UnitTestOptions
opts VM
vm Text
testName [AbiType]
types
runTest opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} VM
vm (InvariantTest Text
testName, []) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case Maybe (Text, ByteString)
replay of
  Maybe (Text, ByteString)
Nothing -> UnitTestOptions
-> VM -> Text -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun UnitTestOptions
opts VM
vm Text
testName []
  Just (Text
sig, ByteString
cds) ->
    if Text
sig forall a. Eq a => a -> a -> Bool
== Text
testName
    then UnitTestOptions
-> VM -> Text -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun UnitTestOptions
opts VM
vm Text
testName (ByteString -> [ExploreTx]
decodeCalls ByteString
cds)
    else UnitTestOptions
-> VM -> Text -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun UnitTestOptions
opts VM
vm Text
testName []
runTest UnitTestOptions
_ VM
_ (InvariantTest Text
_, [AbiType]
types) = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"invariant testing with arguments: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [AbiType]
types forall a. Semigroup a => a -> a -> a
<> [Char]
" is not implemented (yet!)"
runTest UnitTestOptions
opts VM
vm (SymbolicTest Text
testName, [AbiType]
types) = UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
symRun UnitTestOptions
opts VM
vm Text
testName [AbiType]
types

type ExploreTx = (Addr, Addr, ByteString, W256)

decodeCalls :: BSLazy.ByteString -> [ExploreTx]
decodeCalls :: ByteString -> [ExploreTx]
decodeCalls ByteString
b = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"could not decode replay data") forall a b. (a -> b) -> a -> b
$ do
  List [RLP]
v <- ByteString -> Maybe RLP
rlpdecode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSLazy.toStrict ByteString
b
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {a} {b}. (Num a, Num b) => RLP -> (a, b, ByteString, W256)
unList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RLP]
v
  where
    unList :: RLP -> (a, b, ByteString, W256)
unList (List [BS ByteString
caller', BS ByteString
target, BS ByteString
cd, BS ByteString
ts]) =
      (forall a b. (Integral a, Num b) => a -> b
num (ByteString -> W256
word ByteString
caller'), forall a b. (Integral a, Num b) => a -> b
num (ByteString -> W256
word ByteString
target), ByteString
cd, ByteString -> W256
word ByteString
ts)
    unList RLP
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"fix me with better types"

-- | Runs an invariant test, calls the invariant before execution begins
initialExplorationStepper :: UnitTestOptions -> ABIMethod -> [ExploreTx] -> [Addr] -> Int -> Stepper (Bool, RLP)
initialExplorationStepper :: UnitTestOptions
-> Text -> [ExploreTx] -> [Addr] -> Int -> Stepper (Bool, RLP)
initialExplorationStepper UnitTestOptions
opts'' Text
testName [ExploreTx]
replayData [Addr]
targets Int
i = do
  let history :: RLP
history = [RLP] -> RLP
List []
  Bool
x <- UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts'' Text
testName AbiValue
emptyAbi
  if Bool
x
  then UnitTestOptions
-> Text
-> [ExploreTx]
-> [Addr]
-> RLP
-> Int
-> Stepper (Bool, RLP)
explorationStepper UnitTestOptions
opts'' Text
testName [ExploreTx]
replayData [Addr]
targets RLP
history Int
i
  else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, RLP
history)

explorationStepper :: UnitTestOptions -> ABIMethod -> [ExploreTx] -> [Addr] -> RLP -> Int -> Stepper (Bool, RLP)
explorationStepper :: UnitTestOptions
-> Text
-> [ExploreTx]
-> [Addr]
-> RLP
-> Int
-> Stepper (Bool, RLP)
explorationStepper UnitTestOptions
_ Text
_ [ExploreTx]
_ [Addr]
_ RLP
history Int
0  = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, RLP
history)
explorationStepper opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} Text
testName [ExploreTx]
replayData [Addr]
targets (List [RLP]
history) Int
i = do
 (Addr
caller', Addr
target, ByteString
cd, W256
timestamp') <-
   case forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Int
i forall a. Num a => a -> a -> a
- Int
1)) [ExploreTx]
replayData of
     Just ExploreTx
v -> forall (m :: * -> *) a. Monad m => a -> m a
return ExploreTx
v
     Maybe ExploreTx
Nothing ->
      forall a. StateT VM IO a -> Stepper a
Stepper.evmIO forall a b. (a -> b) -> a -> b
$ do
       VM
vm <- forall s (m :: * -> *). MonadState s m => m s
get
       let cs :: Map Addr Contract
cs = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' VM Env
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Env (Map Addr Contract)
contracts) VM
vm
           noCode :: Contract -> Bool
noCode Contract
c = case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract ContractCode
contractcode Contract
c of
             RuntimeCode (ConcreteRuntimeCode ByteString
"") -> Bool
True
             RuntimeCode (SymbolicRuntimeCode Vector (Expr 'Byte)
c') -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector (Expr 'Byte)
c'
             ContractCode
_ -> Bool
False
           mutable :: Method -> Bool
mutable Method
m = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Method Mutability
methodMutability Method
m forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Mutability
NonPayable, Mutability
Payable]
           knownAbis :: Map Addr SolcContract
           knownAbis :: Map Addr SolcContract
knownAbis =
             -- exclude contracts without code
             forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BS.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SolcContract ByteString
runtimeCode) forall a b. (a -> b) -> a -> b
$
             -- exclude contracts without state changing functions
             forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Method -> Bool
mutable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SolcContract (Map Word32 Method)
abiMap) forall a b. (a -> b) -> a -> b
$
             -- exclude testing abis
             forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Lens' SolcContract (Map Word32 Method)
abiMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Word32
unitTestMarkerAbi)) forall a b. (a -> b) -> a -> b
$
             -- pick all contracts with known compiler artifacts
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasCallStack => Maybe a -> a
fromJust (forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Addr
addr, ContractCode -> DappInfo -> Maybe SolcContract
lookupCode (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract ContractCode
contractcode Contract
c) DappInfo
dapp) | (Addr
addr, Contract
c)  <- forall k a. Map k a -> [(k, a)]
Map.toList Map Addr Contract
cs])
           selected :: [(Addr, SolcContract)]
selected = [(Addr
addr,
                        forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error ([Char]
"no src found for: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Addr
addr)) forall a b. (a -> b) -> a -> b
$ ContractCode -> DappInfo -> Maybe SolcContract
lookupCode (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract ContractCode
contractcode (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"contract not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Addr
addr) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Addr
addr Map Addr Contract
cs)) DappInfo
dapp)
                       | Addr
addr  <- [Addr]
targets]
       -- go to IO and generate a random valid call to any known contract
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
         -- select random contract
         (Addr
target, SolcContract
solcInfo) <- forall a. Gen a -> IO a
generate forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Gen a
elements (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
targets then forall k a. Map k a -> [(k, a)]
Map.toList Map Addr SolcContract
knownAbis else [(Addr, SolcContract)]
selected)
         -- choose a random mutable method
         (Word32
_, (Method [(Text, AbiType)]
_ [(Text, AbiType)]
inputs Text
sig Text
_ Mutability
_)) <- forall a. Gen a -> IO a
generate (forall a. [a] -> Gen a
elements forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Method -> Bool
mutable forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SolcContract (Map Word32 Method)
abiMap SolcContract
solcInfo)
         let types :: [AbiType]
types = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, AbiType)]
inputs
         -- set the caller to a random address with 90% probability, 10% known EOA address
         let knownEOAs :: [Addr]
knownEOAs = forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Contract -> Bool
noCode Map Addr Contract
cs
         AbiAddress Addr
caller' <-
           if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
knownEOAs
           then forall a. Gen a -> IO a
generate forall a b. (a -> b) -> a -> b
$ AbiType -> Gen AbiValue
genAbiValue AbiType
AbiAddressType
           else forall a. Gen a -> IO a
generate forall a b. (a -> b) -> a -> b
$ forall a. [(Int, Gen a)] -> Gen a
frequency
             [ (Int
90, AbiType -> Gen AbiValue
genAbiValue AbiType
AbiAddressType)
             , (Int
10, Addr -> AbiValue
AbiAddress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Gen a
elements [Addr]
knownEOAs)
             ]
         -- make a call with random valid data to the function
         AbiValue
args <- forall a. Gen a -> IO a
generate forall a b. (a -> b) -> a -> b
$ AbiType -> Gen AbiValue
genAbiValue (Vector AbiType -> AbiType
AbiTupleType forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList [AbiType]
types)
         let cd :: ByteString
cd = Text -> AbiValue -> ByteString
abiMethod (Text
sig forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"," (([Char] -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AbiType]
types) forall a. Semigroup a => a -> a -> a
<> Text
")") AbiValue
args
         -- increment timestamp with random amount
         W256
timepassed <- forall a b. (Integral a, Num b) => a -> b
num forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> IO a
generate (forall a. Integral a => Gen a
arbitrarySizedNatural :: Gen Word32)
         let ts :: W256
ts = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"symbolic timestamp not supported here") forall a b. (a -> b) -> a -> b
$ Expr 'EWord -> Maybe W256
maybeLitWord forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' VM Block
block forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Block (Expr 'EWord)
timestamp) VM
vm
         forall (m :: * -> *) a. Monad m => a -> m a
return (Addr
caller', Addr
target, ByteString
cd, forall a b. (Integral a, Num b) => a -> b
num W256
ts forall a. Num a => a -> a -> a
+ W256
timepassed)
 let opts' :: UnitTestOptions
opts' = UnitTestOptions
opts { testParams :: TestVMParams
testParams = TestVMParams
testParams {testAddress :: Addr
testAddress = Addr
target, testCaller :: Addr
testCaller = Addr
caller', testTimestamp :: W256
testTimestamp = W256
timestamp'}}
     thisCallRLP :: RLP
thisCallRLP = [RLP] -> RLP
List [ByteString -> RLP
BS forall a b. (a -> b) -> a -> b
$ Addr -> ByteString
word160Bytes Addr
caller', ByteString -> RLP
BS forall a b. (a -> b) -> a -> b
$ Addr -> ByteString
word160Bytes Addr
target, ByteString -> RLP
BS ByteString
cd, ByteString -> RLP
BS forall a b. (a -> b) -> a -> b
$ W256 -> ByteString
word256Bytes W256
timestamp']
 -- set the timestamp
 forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' VM Block
block forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Block (Expr 'EWord)
timestamp) (W256 -> Expr 'EWord
Lit W256
timestamp')
 -- perform the call
 Bool
bailed <- UnitTestOptions -> ByteString -> Stepper Bool
exploreStep UnitTestOptions
opts' ByteString
cd
 forall a. EVM a -> Stepper a
Stepper.evm EVM ()
popTrace
 let newHistory :: RLP
newHistory = if Bool
bailed then [RLP] -> RLP
List [RLP]
history else [RLP] -> RLP
List (RLP
thisCallRLPforall a. a -> [a] -> [a]
:[RLP]
history)
     opts'' :: UnitTestOptions
opts'' = UnitTestOptions
opts {testParams :: TestVMParams
testParams = TestVMParams
testParams {testTimestamp :: W256
testTimestamp = W256
timestamp'}}
     carryOn :: Stepper (Bool, RLP)
carryOn = UnitTestOptions
-> Text
-> [ExploreTx]
-> [Addr]
-> RLP
-> Int
-> Stepper (Bool, RLP)
explorationStepper UnitTestOptions
opts'' Text
testName [ExploreTx]
replayData [Addr]
targets RLP
newHistory (Int
i forall a. Num a => a -> a -> a
- Int
1)
 -- if we didn't revert, run the test function
 if Bool
bailed
 then Stepper (Bool, RLP)
carryOn
 else
   do Bool
x <- UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts'' Text
testName AbiValue
emptyAbi
      if Bool
x
      then Stepper (Bool, RLP)
carryOn
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [RLP] -> RLP
List (RLP
thisCallRLPforall a. a -> [a] -> [a]
:[RLP]
history))
explorationStepper UnitTestOptions
_ Text
_ [ExploreTx]
_ [Addr]
_ RLP
_ Int
_  = forall a. HasCallStack => [Char] -> a
error [Char]
"malformed rlp"

getTargetContracts :: UnitTestOptions -> Stepper [Addr]
getTargetContracts :: UnitTestOptions -> Stepper [Addr]
getTargetContracts UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} = do
  VM
vm <- forall a. EVM a -> Stepper a
Stepper.evm forall s (m :: * -> *). MonadState s m => m s
get
  let contract' :: Contract
contract' = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ VM -> Maybe Contract
currentContract VM
vm
      theAbi :: Map Word32 Method
theAbi = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SolcContract (Map Word32 Method)
abiMap forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ ContractCode -> DappInfo -> Maybe SolcContract
lookupCode (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract ContractCode
contractcode Contract
contract') DappInfo
dapp
      setUp :: Word32
setUp  = ByteString -> Word32
abiKeccak (Text -> ByteString
encodeUtf8 Text
"targetContracts()")
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word32
setUp Map Word32 Method
theAbi of
    Maybe Method
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just Method
_ -> do
      forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams (forall a b. a -> Either a b
Left (Text
"targetContracts()", AbiValue
emptyAbi))
      Either Error (Expr 'Buf)
res <- Stepper (Either Error (Expr 'Buf))
Stepper.execFully
      case Either Error (Expr 'Buf)
res of
        Right (ConcreteBuf ByteString
r) ->
          let vs :: Vector AbiValue
vs = case AbiType -> ByteString -> AbiValue
decodeAbiValue (Vector AbiType -> AbiType
AbiTupleType (forall a. [a] -> Vector a
Vector.fromList [AbiType -> AbiType
AbiArrayDynamicType AbiType
AbiAddressType])) (ByteString -> ByteString
BSLazy.fromStrict ByteString
r) of
                AbiTuple Vector AbiValue
v -> Vector AbiValue
v
                AbiValue
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"fix me with better types"
              targets :: [Addr]
targets = case forall a. Vector a -> [a]
Vector.toList Vector AbiValue
vs of
                [AbiArrayDynamic AbiType
AbiAddressType Vector AbiValue
ts] ->
                  let unAbiAddress :: AbiValue -> Addr
unAbiAddress (AbiAddress Addr
a) = Addr
a
                      unAbiAddress AbiValue
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"fix me with better types"
                  in AbiValue -> Addr
unAbiAddress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Vector a -> [a]
Vector.toList Vector AbiValue
ts
                [AbiValue]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"fix me with better types"
          in forall (f :: * -> *) a. Applicative f => a -> f a
pure [Addr]
targets
        Either Error (Expr 'Buf)
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: unexpected failure code"

exploreRun :: UnitTestOptions -> VM -> ABIMethod -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun :: UnitTestOptions
-> VM -> Text -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} VM
initialVm Text
testName [ExploreTx]
replayTxs = do
  let oracle :: Fetcher
oracle = SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo
  ([Addr]
targets, VM
_) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall a. Fetcher -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret Fetcher
oracle (UnitTestOptions -> Stepper [Addr]
getTargetContracts UnitTestOptions
opts)) VM
initialVm
  let depth :: Int
depth = forall a. a -> Maybe a -> a
fromMaybe Int
20 Maybe Int
maxDepth
  ((Bool
x, RLP
counterex), VM
vm') <-
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExploreTx]
replayTxs
    then
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\a :: ((Bool, RLP), VM)
a@((Bool
success, RLP
_), VM
_) Int
_ ->
                       if Bool
success
                       then forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall a. Fetcher -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret Fetcher
oracle (UnitTestOptions
-> Text -> [ExploreTx] -> [Addr] -> Int -> Stepper (Bool, RLP)
initialExplorationStepper UnitTestOptions
opts Text
testName [] [Addr]
targets Int
depth)) VM
initialVm
                       else forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool, RLP), VM)
a)
                       ((Bool
True, ([RLP] -> RLP
List [])), VM
initialVm)  -- no canonical "post vm"
                       [Int
0..Int
fuzzRuns]
    else forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall a. Fetcher -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret Fetcher
oracle (UnitTestOptions
-> Text -> [ExploreTx] -> [Addr] -> Int -> Stepper (Bool, RLP)
initialExplorationStepper UnitTestOptions
opts Text
testName [ExploreTx]
replayTxs [Addr]
targets (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExploreTx]
replayTxs))) VM
initialVm
  if Bool
x
  then forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\x1b[32m[PASS]\x1b[0m " forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<>  Text
" (runs: " forall a. Semigroup a => a -> a -> a
<> ([Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
fuzzRuns) forall a. Semigroup a => a -> a -> a
<>Text
", depth: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack (forall a. Show a => a -> [Char]
show Int
depth) forall a. Semigroup a => a -> a -> a
<> Text
")",
               forall a b. b -> Either a b
Right (VM -> UnitTestOptions -> Text -> Text
passOutput VM
vm' UnitTestOptions
opts Text
testName), VM
vm') -- no canonical "post vm"
  else let replayText :: Text
replayText = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExploreTx]
replayTxs
                        then Text
"\nReplay data: '(" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack (forall a. Show a => a -> [Char]
show Text
testName) forall a. Semigroup a => a -> a -> a
<> Text
"," forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack (forall a. Show a => a -> [Char]
show (forall a. Show a => a -> [Char]
show (ByteString -> ByteStringS
ByteStringS forall a b. (a -> b) -> a -> b
$ RLP -> ByteString
rlpencode RLP
counterex))) forall a. Semigroup a => a -> a -> a
<> Text
")'"
                        else Text
" (replayed)"
       in forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\x1b[31m[FAIL]\x1b[0m " forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<> Text
replayText, forall a b. a -> Either a b
Left  (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm' UnitTestOptions
opts Text
testName), VM
vm')

execTest :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Bool, VM)
execTest :: UnitTestOptions -> VM -> Text -> AbiValue -> IO (Bool, VM)
execTest opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} VM
vm Text
testName AbiValue
args =
  forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
    (forall a. Fetcher -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) (UnitTestOptions -> Text -> AbiValue -> Stepper Bool
execTestStepper UnitTestOptions
opts Text
testName AbiValue
args))
    VM
vm

-- | Define the thread spawner for normal test cases
runOne :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Text, Either Text Text, VM)
runOne :: UnitTestOptions
-> VM -> Text -> AbiValue -> IO (Text, Either Text Text, VM)
runOne opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} VM
vm Text
testName AbiValue
args = do
  let argInfo :: Text
argInfo = [Char] -> Text
pack (if AbiValue
args forall a. Eq a => a -> a -> Bool
== AbiValue
emptyAbi then [Char]
"" else [Char]
" with arguments: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show AbiValue
args)
  (Bool
bailed, VM
vm') <- UnitTestOptions -> VM -> Text -> AbiValue -> IO (Bool, VM)
execTest UnitTestOptions
opts VM
vm Text
testName AbiValue
args
  (Bool
success, VM
vm'') <-
    forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
      (forall a. Fetcher -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) (UnitTestOptions -> Text -> Bool -> Stepper Bool
checkFailures UnitTestOptions
opts Text
testName Bool
bailed)) VM
vm'
  if Bool
success
  then
     let gasSpent :: Word64
gasSpent = forall a b. (Integral a, Num b) => a -> b
num (TestVMParams -> Word64
testGasCall TestVMParams
testParams) forall a. Num a => a -> a -> a
- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' VM FrameState
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' FrameState Word64
gas) VM
vm'
         gasText :: Text
gasText = [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
gasSpent :: Integer)
     in
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Text
"\x1b[32m[PASS]\x1b[0m "
           forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<> Text
argInfo forall a. Semigroup a => a -> a -> a
<> Text
" (gas: " forall a. Semigroup a => a -> a -> a
<> Text
gasText forall a. Semigroup a => a -> a -> a
<> Text
")"
          , forall a b. b -> Either a b
Right (VM -> UnitTestOptions -> Text -> Text
passOutput VM
vm'' UnitTestOptions
opts Text
testName)
          , VM
vm''
          )
  else if Bool
bailed then
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Text
"\x1b[31m[BAIL]\x1b[0m "
           forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<> Text
argInfo
          , forall a b. a -> Either a b
Left (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm'' UnitTestOptions
opts Text
testName)
          , VM
vm''
          )
      else
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Text
"\x1b[31m[FAIL]\x1b[0m "
           forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<> Text
argInfo
          , forall a b. a -> Either a b
Left (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm'' UnitTestOptions
opts Text
testName)
          , VM
vm''
          )

-- | Define the thread spawner for property based tests
fuzzRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
fuzzRun :: UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
fuzzRun opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} VM
vm Text
testName [AbiType]
types = do
  let args :: Args
args = Args{ replay :: Maybe (QCGen, Int)
replay          = forall a. Maybe a
Nothing
                 , maxSuccess :: Int
maxSuccess      = Int
fuzzRuns
                 , maxDiscardRatio :: Int
maxDiscardRatio = Int
10
                 , maxSize :: Int
maxSize         = Int
100
                 , chatty :: Bool
chatty          = forall a. Maybe a -> Bool
isJust Maybe Int
verbose
                 , maxShrinks :: Int
maxShrinks      = forall a. Bounded a => a
maxBound
                 }
  forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
args (UnitTestOptions -> Text -> [AbiType] -> VM -> Property
fuzzTest UnitTestOptions
opts Text
testName [AbiType]
types VM
vm) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Success Int
numTests Int
_ Map [[Char]] Int
_ Map [Char] Int
_ Map [Char] (Map [Char] Int)
_ [Char]
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[32m[PASS]\x1b[0m "
             forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<> Text
" (runs: " forall a. Semigroup a => a -> a -> a
<> ([Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
numTests) forall a. Semigroup a => a -> a -> a
<> Text
")"
             -- this isn't the post vm we actually want, as we
             -- can't retrieve the correct vm from quickcheck
           , forall a b. b -> Either a b
Right (VM -> UnitTestOptions -> Text -> Text
passOutput VM
vm UnitTestOptions
opts Text
testName)
           , VM
vm
           )
    Failure Int
_ Int
_ Int
_ Int
_ Int
_ QCGen
_ Int
_ [Char]
_ Maybe AnException
_ [Char]
_ [[Char]]
failCase [[Char]]
_ Set [Char]
_ ->
      let abiValue :: AbiValue
abiValue = AbiType -> ByteString -> AbiValue
decodeAbiValue (Vector AbiType -> AbiType
AbiTupleType (forall a. [a] -> Vector a
Vector.fromList [AbiType]
types)) forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSLazy.fromStrict forall a b. (a -> b) -> a -> b
$ Text -> ByteString
hexText ([Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
failCase)
          ppOutput :: Text
ppOutput = [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show AbiValue
abiValue
      in do
        -- Run the failing test again to get a proper trace
        VM
vm' <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (forall a. Fetcher -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) (UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts Text
testName AbiValue
abiValue)) VM
vm
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[31m[FAIL]\x1b[0m "
               forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<> Text
". Counterexample: " forall a. Semigroup a => a -> a -> a
<> Text
ppOutput
               forall a. Semigroup a => a -> a -> a
<> Text
"\nRun:\n dapp test --replay '(\"" forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<> Text
"\",\""
               forall a. Semigroup a => a -> a -> a
<> ([Char] -> Text
pack (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
failCase)) forall a. Semigroup a => a -> a -> a
<> Text
"\")'\nto test this case again, or \n dapp debug --replay '(\""
               forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<> Text
"\",\"" forall a. Semigroup a => a -> a -> a
<> ([Char] -> Text
pack (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
failCase)) forall a. Semigroup a => a -> a -> a
<> Text
"\")'\nto debug it."
             , forall a b. a -> Either a b
Left (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm' UnitTestOptions
opts Text
testName)
             , VM
vm'
             )
    Result
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[31m[OOPS]\x1b[0m "
               forall a. Semigroup a => a -> a -> a
<> Text
testName
              , forall a b. a -> Either a b
Left (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm UnitTestOptions
opts Text
testName)
              , VM
vm
              )

-- | Define the thread spawner for symbolic tests
symRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
symRun :: UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
symRun opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} VM
vm Text
testName [AbiType]
types = do
    let cd :: (Expr 'Buf, [Prop])
cd = Text -> [AbiType] -> [[Char]] -> Expr 'Buf -> (Expr 'Buf, [Prop])
symCalldata Text
testName [AbiType]
types [] (Text -> Expr 'Buf
AbstractBuf Text
"txdata")
        shouldFail :: Bool
shouldFail = Text
"proveFail" Text -> Text -> Bool
`isPrefixOf` Text
testName
        testContract :: Addr
testContract = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' VM FrameState
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' FrameState Addr
contract) VM
vm

    -- define postcondition depending on `shouldFail`
    -- We directly encode the failure conditions from failed() in ds-test since this is easier to encode than a call into failed()
    -- we need to read from slot 0 in the test contract and mask it with 0x10 to get the value of _failed
    -- we don't need to do this when reading the failed from the cheatcode address since we don't do any packing there
    let failed :: Expr 'Storage -> Prop
failed Expr 'Storage
store = (Expr 'EWord -> Expr 'EWord -> Expr 'EWord
And (Expr 'EWord -> Expr 'EWord -> Expr 'Storage -> Expr 'EWord
readStorage' (Addr -> Expr 'EWord
litAddr Addr
testContract) (W256 -> Expr 'EWord
Lit W256
0) Expr 'Storage
store) (W256 -> Expr 'EWord
Lit W256
2) forall (a :: EType). Typeable a => Expr a -> Expr a -> Prop
.== W256 -> Expr 'EWord
Lit W256
2)
                   Prop -> Prop -> Prop
.|| (Expr 'EWord -> Expr 'EWord -> Expr 'Storage -> Expr 'EWord
readStorage' (Addr -> Expr 'EWord
litAddr Addr
cheatCode) (W256 -> Expr 'EWord
Lit W256
0x6661696c65640000000000000000000000000000000000000000000000000000) Expr 'Storage
store forall (a :: EType). Typeable a => Expr a -> Expr a -> Prop
.== W256 -> Expr 'EWord
Lit W256
1)
        postcondition :: VM -> Expr 'End -> Prop
postcondition = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a -> b) -> a -> b
$ case Bool
shouldFail of
          Bool
True -> \(VM
_, Expr 'End
post) -> case Expr 'End
post of
                                  Return [Prop]
_ Expr 'Buf
_ Expr 'Storage
store -> Expr 'Storage -> Prop
failed Expr 'Storage
store
                                  Expr 'End
_ -> Bool -> Prop
PBool Bool
True
          Bool
False -> \(VM
_, Expr 'End
post) -> case Expr 'End
post of
                                   Return [Prop]
_ Expr 'Buf
_ Expr 'Storage
store -> Prop -> Prop
PNeg (Expr 'Storage -> Prop
failed Expr 'Storage
store)
                                   Expr 'End
_ -> Bool -> Prop
PBool Bool
False

    (()
_, VM
vm') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
      (forall a. Fetcher -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) (forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ do
          EVM ()
popTrace
          TestVMParams -> (Expr 'Buf, [Prop]) -> EVM ()
makeTxCall TestVMParams
testParams (Expr 'Buf, [Prop])
cd
        )) VM
vm

    -- check postconditions against vm
    (Expr 'End
_, [VerifyResult]
results) <- SolverGroup
-> VeriOpts
-> VM
-> Maybe (VM -> Expr 'End -> Prop)
-> IO (Expr 'End, [VerifyResult])
verify SolverGroup
solvers (UnitTestOptions -> VeriOpts
makeVeriOpts UnitTestOptions
opts) VM
vm' (forall a. a -> Maybe a
Just VM -> Expr 'End -> Prop
postcondition)

    -- display results
    if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b c. ProofResult a b c -> Bool
isQed [VerifyResult]
results
    then do
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\x1b[32m[PASS]\x1b[0m " forall a. Semigroup a => a -> a -> a
<> Text
testName, forall a b. b -> Either a b
Right Text
"", VM
vm)
    else do
      let x :: [(Expr 'End, SMTCex)]
x = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VerifyResult -> Maybe (Expr 'End, SMTCex)
extractCex [VerifyResult]
results
      let y :: Text
y = UnitTestOptions
-> Text -> Expr 'Buf -> [AbiType] -> [(Expr 'End, SMTCex)] -> Text
symFailure UnitTestOptions
opts Text
testName (forall a b. (a, b) -> a
fst (Expr 'Buf, [Prop])
cd) [AbiType]
types [(Expr 'End, SMTCex)]
x
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\x1b[31m[FAIL]\x1b[0m " forall a. Semigroup a => a -> a -> a
<> Text
testName, forall a b. a -> Either a b
Left Text
y, VM
vm)

symFailure :: UnitTestOptions -> Text -> Expr Buf -> [AbiType] -> [(Expr End, SMTCex)] -> Text
symFailure :: UnitTestOptions
-> Text -> Expr 'Buf -> [AbiType] -> [(Expr 'End, SMTCex)] -> Text
symFailure UnitTestOptions {Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..} Text
testName Expr 'Buf
cd [AbiType]
types [(Expr 'End, SMTCex)]
failures' =
  forall a. Monoid a => [a] -> a
mconcat
    [ Text
"Failure: "
    , Text
testName
    , Text
"\n\n"
    , Text -> [Text] -> Text
intercalate Text
"\n" forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
indentLines Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr 'End, SMTCex) -> Text
mkMsg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Expr 'End, SMTCex)]
failures'
    ]
    where
      ctx :: DappContext
ctx = DappContext { _contextInfo :: DappInfo
_contextInfo = DappInfo
dapp, _contextEnv :: Map Addr Contract
_contextEnv = forall a. Monoid a => a
mempty }
      showRes :: Expr 'End -> Text
showRes = \case
                       Return [Prop]
_ Expr 'Buf
_ Expr 'Storage
_ -> if Text
"proveFail" Text -> Text -> Bool
`isPrefixOf` Text
testName
                                      then Text
"Successful execution"
                                      else Text
"Failed: DSTest Assertion Violation"
                       Expr 'End
res ->
                         --let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts}
                         let ?context = DappContext
ctx
                         in [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ (?context::DappContext) => Expr 'End -> [Char]
prettyvmresult Expr 'End
res
      mkMsg :: (Expr 'End, SMTCex) -> Text
mkMsg (Expr 'End
leaf, SMTCex
cex) = [Text] -> Text
Text.unlines
        [Text
"Counterexample:"
        ,Text
""
        ,Text
"  result:   " forall a. Semigroup a => a -> a -> a
<> Expr 'End -> Text
showRes Expr 'End
leaf
        ,Text
"  calldata: " forall a. Semigroup a => a -> a -> a
<> let ?context = DappContext
ctx in (?context::DappContext) =>
SMTCex -> Expr 'Buf -> Text -> [AbiType] -> Text
prettyCalldata SMTCex
cex Expr 'Buf
cd Text
testName [AbiType]
types
        , case Maybe Int
verbose of
            --Just _ -> unlines
              --[ ""
              --, unpack $ indentLines 2 (showTraceTree dapp vm)
              --]
            Maybe Int
_ -> Text
""
        ]

prettyCalldata :: (?context :: DappContext) => SMTCex -> Expr Buf -> Text -> [AbiType] -> Text
prettyCalldata :: (?context::DappContext) =>
SMTCex -> Expr 'Buf -> Text -> [AbiType] -> Text
prettyCalldata SMTCex
cex Expr 'Buf
buf Text
sig [AbiType]
types = forall a. [a] -> a
head (Text -> Text -> [Text]
Text.splitOn Text
"(" Text
sig) forall a. Semigroup a => a -> a -> a
<> (?context::DappContext) => SMTCex -> [AbiType] -> Expr 'Buf -> Text
showCalldata SMTCex
cex [AbiType]
types Expr 'Buf
buf

showCalldata :: (?context :: DappContext) => SMTCex -> [AbiType] -> Expr Buf -> Text
showCalldata :: (?context::DappContext) => SMTCex -> [AbiType] -> Expr 'Buf -> Text
showCalldata SMTCex
cex [AbiType]
tps Expr 'Buf
buf = Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"," (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbiValue -> Text
showVal [AbiValue]
vals) forall a. Semigroup a => a -> a -> a
<> Text
")"
  where
    argdata :: Expr 'Buf
argdata = W256 -> Expr 'Buf -> Expr 'Buf
Expr.drop W256
4 forall a b. (a -> b) -> a -> b
$ forall (a :: EType). Expr a -> Expr a
simplify forall a b. (a -> b) -> a -> b
$ forall (a :: EType). SMTCex -> Expr a -> Expr a
subModel SMTCex
cex Expr 'Buf
buf
    vals :: [AbiValue]
vals = case [AbiType] -> Expr 'Buf -> AbiVals
decodeBuf [AbiType]
tps Expr 'Buf
argdata of
             CAbi [AbiValue]
v -> [AbiValue]
v
             AbiVals
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Internal Error: unable to abi decode function arguments:\n" forall a. Semigroup a => a -> a -> a
<> (Text -> [Char]
Text.unpack forall a b. (a -> b) -> a -> b
$ forall (a :: EType). Expr a -> Text
formatExpr Expr 'Buf
argdata)

showVal :: AbiValue -> Text
showVal :: AbiValue -> Text
showVal (AbiBytes Int
_ ByteString
bs) = ByteString -> Text
formatBytes ByteString
bs
showVal (AbiAddress Addr
addr) = [Char] -> Text
Text.pack  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Addr
addr
showVal AbiValue
v = [Char] -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ AbiValue
v


-- prettyCalldata :: (?context :: DappContext) => Expr Buf -> Text -> [AbiType]-> IO Text
-- prettyCalldata buf sig types = do
--   cdlen' <- num <$> SBV.getValue cdlen
--   cd <- case buf of
--     ConcreteBuf cd -> return $ BS.take cdlen' cd
--     cd -> mapM (SBV.getValue . fromSized) (take cdlen' cd) <&> BS.pack
--   pure $ (head (Text.splitOn "(" sig)) <> showCall types (ConcreteBuffer cd)

execSymTest :: UnitTestOptions -> ABIMethod -> (Expr Buf, [Prop]) -> Stepper (Expr End)
execSymTest :: UnitTestOptions
-> Text -> (Expr 'Buf, [Prop]) -> Stepper (Expr 'End)
execSymTest UnitTestOptions{ Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
.. } Text
method (Expr 'Buf, [Prop])
cd = do
  -- Set up the call to the test method
  forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ do
    TestVMParams -> (Expr 'Buf, [Prop]) -> EVM ()
makeTxCall TestVMParams
testParams (Expr 'Buf, [Prop])
cd
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
method)
  -- Try running the test method
  Stepper (Expr 'End)
runExpr

checkSymFailures :: UnitTestOptions -> Stepper VM
checkSymFailures :: UnitTestOptions -> Stepper VM
checkSymFailures UnitTestOptions { Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
.. } = do
  -- Ask whether any assertions failed
  forall a. EVM a -> Stepper a
Stepper.evm forall a b. (a -> b) -> a -> b
$ do
    EVM ()
popTrace
    TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams (forall a b. a -> Either a b
Left (Text
"failed()", AbiValue
emptyAbi))
  Stepper VM
Stepper.runFully

indentLines :: Int -> Text -> Text
indentLines :: Int -> Text -> Text
indentLines Int
n Text
s =
  let p :: Text
p = Int -> Text -> Text
Text.replicate Int
n Text
" "
  in [Text] -> Text
Text.unlines (forall a b. (a -> b) -> [a] -> [b]
map (Text
p <>) (Text -> [Text]
Text.lines Text
s))

passOutput :: VM -> UnitTestOptions -> Text -> Text
passOutput :: VM -> UnitTestOptions -> Text -> Text
passOutput VM
vm UnitTestOptions { Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
.. } Text
testName =
  let ?context = DappContext { _contextInfo :: DappInfo
_contextInfo = DappInfo
dapp, _contextEnv :: Map Addr Contract
_contextEnv = VM
vm forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Lens' VM Env
EVM.env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Env (Map Addr Contract)
EVM.contracts }
  in let v :: Int
v = forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
verbose
  in if (Int
v forall a. Ord a => a -> a -> Bool
> Int
1) then
    forall a. Monoid a => [a] -> a
mconcat
      [ Text
"Success: "
      , forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> Text -> Maybe Text
stripSuffix Text
"()" Text
testName)
      , Text
"\n"
      , if (Int
v forall a. Ord a => a -> a -> Bool
> Int
2) then Int -> Text -> Text
indentLines Int
2 (DappInfo -> VM -> Text
showTraceTree DappInfo
dapp VM
vm) else Text
""
      , Int -> Text -> Text
indentLines Int
2 ((?context::DappContext) => Map W256 Event -> [Expr 'Log] -> Text
formatTestLogs (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' DappInfo (Map W256 Event)
dappEventMap DappInfo
dapp) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' VM [Expr 'Log]
logs VM
vm))
      , Text
"\n"
      ]
    else Text
""

-- TODO
failOutput :: VM -> UnitTestOptions -> Text -> Text
failOutput :: VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm UnitTestOptions { Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
.. } Text
testName =
  let ?context = DappContext { _contextInfo :: DappInfo
_contextInfo = DappInfo
dapp, _contextEnv :: Map Addr Contract
_contextEnv = VM
vm forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Lens' VM Env
EVM.env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Env (Map Addr Contract)
EVM.contracts}
  in forall a. Monoid a => [a] -> a
mconcat
  [ Text
"Failure: "
  , forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> Text -> Maybe Text
stripSuffix Text
"()" Text
testName)
  , Text
"\n"
  , case Maybe Int
verbose of
      Just Int
_ -> Int -> Text -> Text
indentLines Int
2 (DappInfo -> VM -> Text
showTraceTree DappInfo
dapp VM
vm)
      Maybe Int
_ -> Text
""
  , Int -> Text -> Text
indentLines Int
2 ((?context::DappContext) => Map W256 Event -> [Expr 'Log] -> Text
formatTestLogs (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' DappInfo (Map W256 Event)
dappEventMap DappInfo
dapp) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' VM [Expr 'Log]
logs VM
vm))
  , Text
"\n"
  ]

formatTestLogs :: (?context :: DappContext) => Map W256 Event -> [Expr Log] -> Text
formatTestLogs :: (?context::DappContext) => Map W256 Event -> [Expr 'Log] -> Text
formatTestLogs Map W256 Event
events [Expr 'Log]
xs =
  case forall a. [Maybe a] -> [a]
catMaybes (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((?context::DappContext) =>
Map W256 Event -> Expr 'Log -> Maybe Text
formatTestLog Map W256 Event
events) [Expr 'Log]
xs)) of
    [] -> Text
"\n"
    [Text]
ys -> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"\n" [Text]
ys forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"

-- Here we catch and render some special logs emitted by ds-test,
-- with the intent to then present them in a separate view to the
-- regular trace output.
formatTestLog :: (?context :: DappContext) => Map W256 Event -> Expr Log -> Maybe Text
formatTestLog :: (?context::DappContext) =>
Map W256 Event -> Expr 'Log -> Maybe Text
formatTestLog Map W256 Event
_ (LogEntry Expr 'EWord
_ Expr 'Buf
_ []) = forall a. Maybe a
Nothing
formatTestLog Map W256 Event
_ (GVar GVar 'Log
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"unexpected global variable"
formatTestLog Map W256 Event
events (LogEntry Expr 'EWord
_ Expr 'Buf
args (Expr 'EWord
topic:[Expr 'EWord]
_)) =
  case Expr 'EWord -> Maybe W256
maybeLitWord Expr 'EWord
topic forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \W256
t1 -> (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup W256
t1 Map W256 Event
events) of
    Maybe Event
Nothing -> forall a. Maybe a
Nothing
    Just (Event Text
name Anonymity
_ [(Text, AbiType, Indexed)]
types) ->
      case (Text
name forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
parenthesise (AbiType -> Text
abiTypeSolidity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Text, AbiType, Indexed)] -> [AbiType]
unindexed [(Text, AbiType, Indexed)]
types))) of
        Text
"log(string)" -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Text
unquote forall a b. (a -> b) -> a -> b
$ (?context::DappContext) => AbiType -> Expr 'Buf -> Text
showValue AbiType
AbiStringType Expr 'Buf
args

        -- log_named_x(string, x)
        Text
"log_named_bytes32(string, bytes32)" -> Maybe Text
log_named
        Text
"log_named_address(string, address)" -> Maybe Text
log_named
        Text
"log_named_int(string, int256)"      -> Maybe Text
log_named
        Text
"log_named_uint(string, uint256)"    -> Maybe Text
log_named
        Text
"log_named_bytes(string, bytes)"     -> Maybe Text
log_named
        Text
"log_named_string(string, string)"   -> Maybe Text
log_named

        -- log_named_decimal_x(string, uint, x)
        Text
"log_named_decimal_int(string, int256, uint256)"   -> Maybe Text
log_named_decimal
        Text
"log_named_decimal_uint(string, uint256, uint256)" -> Maybe Text
log_named_decimal

        -- log_x(x)
        Text
"log_bytes32(bytes32)" -> Maybe Text
log_unnamed
        Text
"log_address(address)" -> Maybe Text
log_unnamed
        Text
"log_int(int256)"      -> Maybe Text
log_unnamed
        Text
"log_uint(uint256)"    -> Maybe Text
log_unnamed
        Text
"log_bytes(bytes)"     -> Maybe Text
log_unnamed
        Text
"log_string(string)"   -> Maybe Text
log_unnamed

        -- log_named_x(bytes32, x), as used in older versions of ds-test.
        -- bytes32 are opportunistically represented as strings in Format.hs
        Text
"log_named_bytes32(bytes32, bytes32)" -> Maybe Text
log_named
        Text
"log_named_address(bytes32, address)" -> Maybe Text
log_named
        Text
"log_named_int(bytes32, int256)"      -> Maybe Text
log_named
        Text
"log_named_uint(bytes32, uint256)"    -> Maybe Text
log_named

        Text
_ -> forall a. Maybe a
Nothing

        where
          ts :: [AbiType]
ts = [(Text, AbiType, Indexed)] -> [AbiType]
unindexed [(Text, AbiType, Indexed)]
types
          unquote :: Text -> Text
unquote = (Char -> Bool) -> Text -> Text
Text.dropAround (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'«' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'»')
          log_unnamed :: Maybe Text
log_unnamed =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (?context::DappContext) => AbiType -> Expr 'Buf -> Text
showValue (forall a. [a] -> a
head [AbiType]
ts) Expr 'Buf
args
          log_named :: Maybe Text
log_named =
            let (Text
key, Text
val) = case forall a. Int -> [a] -> [a]
take Int
2 ((?context::DappContext) => [AbiType] -> Expr 'Buf -> [Text]
textValues [AbiType]
ts Expr 'Buf
args) of
                  [Text
k, Text
v] -> (Text
k, Text
v)
                  [Text]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"shouldn't happen"
            in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Text
unquote Text
key forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
val
          showDecimal :: a -> i -> Text
showDecimal a
dec i
val =
            [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall i. Word8 -> i -> DecimalRaw i
Decimal (forall a b. (Integral a, Num b) => a -> b
num a
dec) i
val
          log_named_decimal :: Maybe Text
log_named_decimal =
            case Expr 'Buf
args of
              (ConcreteBuf ByteString
b) ->
                case forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a. Get a -> ByteString -> a
runGet (Int -> [AbiType] -> Get (Vector AbiValue)
getAbiSeq (forall (t :: * -> *) a. Foldable t => t a -> Int
length [AbiType]
ts) [AbiType]
ts) (ByteString -> ByteString
BSLazy.fromStrict ByteString
b) of
                  [AbiValue
key, (AbiUInt Int
256 Word256
val), (AbiUInt Int
256 Word256
dec)] ->
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Text -> Text
unquote ((?context::DappContext) => AbiValue -> Text
showAbiValue AbiValue
key)) forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall {i} {a}. (Show i, Integral i, Integral a) => a -> i -> Text
showDecimal Word256
dec Word256
val
                  [AbiValue
key, (AbiInt Int
256 Int256
val), (AbiUInt Int
256 Word256
dec)] ->
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Text -> Text
unquote ((?context::DappContext) => AbiValue -> Text
showAbiValue AbiValue
key)) forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall {i} {a}. (Show i, Integral i, Integral a) => a -> i -> Text
showDecimal Word256
dec Int256
val
                  [AbiValue]
_ -> forall a. Maybe a
Nothing
              Expr 'Buf
_ -> forall a. a -> Maybe a
Just Text
"<symbolic decimal>"


word32Bytes :: Word32 -> ByteString
word32Bytes :: Word32 -> ByteString
word32Bytes Word32
x = [Word8] -> ByteString
BS.pack [forall a b. (Bits a, Bits b, Integral a, Num b) => a -> Int -> b
byteAt Word32
x (Int
3 forall a. Num a => a -> a -> a
- Int
i) | Int
i <- [Int
0..Int
3]]

abiCall :: TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall :: TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
params Either (Text, AbiValue) ByteString
args =
  let cd :: ByteString
cd = case Either (Text, AbiValue) ByteString
args of
        Left (Text
sig, AbiValue
args') -> Text -> AbiValue -> ByteString
abiMethod Text
sig AbiValue
args'
        Right ByteString
b -> ByteString
b
  in TestVMParams -> (Expr 'Buf, [Prop]) -> EVM ()
makeTxCall TestVMParams
params (ByteString -> Expr 'Buf
ConcreteBuf ByteString
cd, [])

makeTxCall :: TestVMParams -> (Expr Buf, [Prop]) -> EVM ()
makeTxCall :: TestVMParams -> (Expr 'Buf, [Prop]) -> EVM ()
makeTxCall TestVMParams{Word64
Addr
W256
testChainId :: W256
testPrevrandao :: W256
testMaxCodeSize :: W256
testGasprice :: W256
testGaslimit :: Word64
testTimestamp :: W256
testNumber :: W256
testCoinbase :: Addr
testBalanceCreate :: W256
testPriorityFee :: W256
testBaseFee :: W256
testGasCall :: Word64
testGasCreate :: Word64
testOrigin :: Addr
testCaller :: Addr
testAddress :: Addr
testChainId :: TestVMParams -> W256
testPrevrandao :: TestVMParams -> W256
testMaxCodeSize :: TestVMParams -> W256
testGasprice :: TestVMParams -> W256
testGaslimit :: TestVMParams -> Word64
testTimestamp :: TestVMParams -> W256
testNumber :: TestVMParams -> W256
testCoinbase :: TestVMParams -> Addr
testBalanceCreate :: TestVMParams -> W256
testPriorityFee :: TestVMParams -> W256
testBaseFee :: TestVMParams -> W256
testGasCall :: TestVMParams -> Word64
testGasCreate :: TestVMParams -> Word64
testOrigin :: TestVMParams -> Addr
testCaller :: TestVMParams -> Addr
testAddress :: TestVMParams -> Addr
..} (Expr 'Buf
cd, [Prop]
cdProps) = do
  EVM ()
resetState
  forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' VM TxState
tx forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TxState Bool
isCreate) Bool
False
  Addr -> EVM ()
loadContract Addr
testAddress
  forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' VM FrameState
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' FrameState (Expr 'Buf)
EVM.calldata) Expr 'Buf
cd
  Lens' VM [Prop]
constraints forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Semigroup a => a -> a -> a
<> [Prop]
cdProps)
  forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' VM FrameState
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' FrameState (Expr 'EWord)
caller) (Addr -> Expr 'EWord
litAddr Addr
testCaller)
  forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' VM FrameState
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' FrameState Word64
gas) Word64
testGasCall
  Contract
origin' <- forall a. a -> Maybe a -> a
fromMaybe (ContractCode -> Contract
initialContract (RuntimeCode -> ContractCode
RuntimeCode (ByteString -> RuntimeCode
ConcreteRuntimeCode ByteString
""))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' VM Env
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Env (Map Addr Contract)
contracts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Addr
testOrigin)
  let originBal :: W256
originBal = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Contract W256
balance Contract
origin'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (W256
originBal forall a. Ord a => a -> a -> Bool
< W256
testGasprice forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
num Word64
testGasCall)) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"insufficient balance for gas cost"
  VM
vm <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ VM -> VM
initTx VM
vm

initialUnitTestVm :: UnitTestOptions -> SolcContract -> VM
initialUnitTestVm :: UnitTestOptions -> SolcContract -> VM
initialUnitTestVm (UnitTestOptions {Bool
Int
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
ffiAllowed :: Bool
testParams :: TestVMParams
dapp :: DappInfo
vmModifier :: VM -> VM
replay :: Maybe (Text, ByteString)
fuzzRuns :: Int
match :: Text
covMatch :: Maybe Text
solver :: Maybe Text
smtTimeout :: Maybe Natural
maxDepth :: Maybe Int
smtDebug :: Bool
askSmtIters :: Maybe Integer
maxIter :: Maybe Integer
verbose :: Maybe Int
solvers :: SolverGroup
rpcInfo :: RpcInfo
ffiAllowed :: UnitTestOptions -> Bool
testParams :: UnitTestOptions -> TestVMParams
dapp :: UnitTestOptions -> DappInfo
vmModifier :: UnitTestOptions -> VM -> VM
replay :: UnitTestOptions -> Maybe (Text, ByteString)
fuzzRuns :: UnitTestOptions -> Int
match :: UnitTestOptions -> Text
covMatch :: UnitTestOptions -> Maybe Text
solver :: UnitTestOptions -> Maybe Text
smtTimeout :: UnitTestOptions -> Maybe Natural
maxDepth :: UnitTestOptions -> Maybe Int
smtDebug :: UnitTestOptions -> Bool
askSmtIters :: UnitTestOptions -> Maybe Integer
maxIter :: UnitTestOptions -> Maybe Integer
verbose :: UnitTestOptions -> Maybe Int
solvers :: UnitTestOptions -> SolverGroup
rpcInfo :: UnitTestOptions -> RpcInfo
..}) SolcContract
theContract =
  let
    TestVMParams {Word64
Addr
W256
testChainId :: W256
testPrevrandao :: W256
testMaxCodeSize :: W256
testGasprice :: W256
testGaslimit :: Word64
testTimestamp :: W256
testNumber :: W256
testCoinbase :: Addr
testBalanceCreate :: W256
testPriorityFee :: W256
testBaseFee :: W256
testGasCall :: Word64
testGasCreate :: Word64
testOrigin :: Addr
testCaller :: Addr
testAddress :: Addr
testChainId :: TestVMParams -> W256
testPrevrandao :: TestVMParams -> W256
testMaxCodeSize :: TestVMParams -> W256
testGasprice :: TestVMParams -> W256
testGaslimit :: TestVMParams -> Word64
testTimestamp :: TestVMParams -> W256
testNumber :: TestVMParams -> W256
testCoinbase :: TestVMParams -> Addr
testBalanceCreate :: TestVMParams -> W256
testPriorityFee :: TestVMParams -> W256
testBaseFee :: TestVMParams -> W256
testGasCall :: TestVMParams -> Word64
testGasCreate :: TestVMParams -> Word64
testOrigin :: TestVMParams -> Addr
testCaller :: TestVMParams -> Addr
testAddress :: TestVMParams -> Addr
..} = TestVMParams
testParams
    vm :: VM
vm = VMOpts -> VM
makeVm forall a b. (a -> b) -> a -> b
$ VMOpts
           { vmoptContract :: Contract
vmoptContract = ContractCode -> Contract
initialContract (ByteString -> Expr 'Buf -> ContractCode
InitCode (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SolcContract ByteString
creationCode SolcContract
theContract) forall a. Monoid a => a
mempty)
           , vmoptCalldata :: (Expr 'Buf, [Prop])
vmoptCalldata = forall a. Monoid a => a
mempty
           , vmoptValue :: Expr 'EWord
vmoptValue = W256 -> Expr 'EWord
Lit W256
0
           , vmoptAddress :: Addr
vmoptAddress = Addr
testAddress
           , vmoptCaller :: Expr 'EWord
vmoptCaller = Addr -> Expr 'EWord
litAddr Addr
testCaller
           , vmoptOrigin :: Addr
vmoptOrigin = Addr
testOrigin
           , vmoptGas :: Word64
vmoptGas = Word64
testGasCreate
           , vmoptGaslimit :: Word64
vmoptGaslimit = Word64
testGasCreate
           , vmoptCoinbase :: Addr
vmoptCoinbase = Addr
testCoinbase
           , vmoptNumber :: W256
vmoptNumber = W256
testNumber
           , vmoptTimestamp :: Expr 'EWord
vmoptTimestamp = W256 -> Expr 'EWord
Lit W256
testTimestamp
           , vmoptBlockGaslimit :: Word64
vmoptBlockGaslimit = Word64
testGaslimit
           , vmoptGasprice :: W256
vmoptGasprice = W256
testGasprice
           , vmoptBaseFee :: W256
vmoptBaseFee = W256
testBaseFee
           , vmoptPriorityFee :: W256
vmoptPriorityFee = W256
testPriorityFee
           , vmoptMaxCodeSize :: W256
vmoptMaxCodeSize = W256
testMaxCodeSize
           , vmoptPrevRandao :: W256
vmoptPrevRandao = W256
testPrevrandao
           , vmoptSchedule :: FeeSchedule Word64
vmoptSchedule = forall n. Num n => FeeSchedule n
FeeSchedule.berlin
           , vmoptChainId :: W256
vmoptChainId = W256
testChainId
           , vmoptCreate :: Bool
vmoptCreate = Bool
True
           , vmoptStorageBase :: StorageBase
vmoptStorageBase = StorageBase
Concrete
           , vmoptTxAccessList :: Map Addr [W256]
vmoptTxAccessList = forall a. Monoid a => a
mempty -- TODO: support unit test access lists???
           , vmoptAllowFFI :: Bool
vmoptAllowFFI = Bool
ffiAllowed
           }
    creator :: Contract
creator =
      ContractCode -> Contract
initialContract (RuntimeCode -> ContractCode
RuntimeCode (ByteString -> RuntimeCode
ConcreteRuntimeCode ByteString
""))
        forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Contract W256
nonce W256
1
        forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Contract W256
balance W256
testBalanceCreate
  in VM
vm
    forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' VM Env
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Env (Map Addr Contract)
contracts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Addr
ethrunAddress) (forall a. a -> Maybe a
Just Contract
creator)


getParametersFromEnvironmentVariables :: Maybe Text -> IO TestVMParams
getParametersFromEnvironmentVariables :: Maybe Text -> IO TestVMParams
getParametersFromEnvironmentVariables Maybe Text
rpc = do
  BlockNumber
block' <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe BlockNumber
Fetch.Latest (W256 -> BlockNumber
Fetch.BlockNumber forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => [Char] -> a
read) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO (Maybe [Char])
lookupEnv [Char]
"DAPP_TEST_NUMBER")

  (Addr
miner,Expr 'EWord
ts,W256
blockNum,W256
ran,Word64
limit,W256
base) <-
    case Maybe Text
rpc of
      Maybe Text
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return (Addr
0,W256 -> Expr 'EWord
Lit W256
0,W256
0,W256
0,Word64
0,W256
0)
      Just Text
url -> BlockNumber -> Text -> IO (Maybe Block)
Fetch.fetchBlockFrom BlockNumber
block' Text
url forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Block
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"Could not fetch block"
        Just EVM.Block{Word64
FeeSchedule Word64
Addr
Expr 'EWord
W256
_schedule :: Block -> FeeSchedule Word64
_maxCodeSize :: Block -> W256
_baseFee :: Block -> W256
_gaslimit :: Block -> Word64
_prevRandao :: Block -> W256
_number :: Block -> W256
_timestamp :: Block -> Expr 'EWord
_coinbase :: Block -> Addr
_schedule :: FeeSchedule Word64
_maxCodeSize :: W256
_baseFee :: W256
_gaslimit :: Word64
_prevRandao :: W256
_number :: W256
_timestamp :: Expr 'EWord
_coinbase :: Addr
..} -> forall (m :: * -> *) a. Monad m => a -> m a
return (  Addr
_coinbase
                                      , Expr 'EWord
_timestamp
                                      , W256
_number
                                      , W256
_prevRandao
                                      , Word64
_gaslimit
                                      , W256
_baseFee
                                      )
  let
    getWord :: [Char] -> b -> IO b
getWord [Char]
s b
def = forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
def forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
s
    getAddr :: [Char] -> b -> IO b
getAddr [Char]
s b
def = forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
def forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
s
    ts' :: W256
ts' = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"Internal Error: received unexpected symbolic timestamp via rpc") (Expr 'EWord -> Maybe W256
maybeLitWord Expr 'EWord
ts)

  Addr
-> Addr
-> Addr
-> Word64
-> Word64
-> W256
-> W256
-> W256
-> Addr
-> W256
-> W256
-> Word64
-> W256
-> W256
-> W256
-> W256
-> TestVMParams
TestVMParams
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b}. Read b => [Char] -> b -> IO b
getAddr [Char]
"DAPP_TEST_ADDRESS" (Addr -> W256 -> Addr
createAddress Addr
ethrunAddress W256
1)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getAddr [Char]
"DAPP_TEST_CALLER" Addr
ethrunAddress
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getAddr [Char]
"DAPP_TEST_ORIGIN" Addr
ethrunAddress
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_GAS_CREATE" Word64
defaultGasForCreating
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_GAS_CALL" Word64
defaultGasForInvoking
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_BASEFEE" W256
base
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_PRIORITYFEE" W256
0
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_BALANCE" W256
defaultBalanceForTestContract
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getAddr [Char]
"DAPP_TEST_COINBASE" Addr
miner
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_NUMBER" W256
blockNum
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_TIMESTAMP" W256
ts'
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_GAS_LIMIT" Word64
limit
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_GAS_PRICE" W256
0
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_MAXCODESIZE" W256
defaultMaxCodeSize
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_PREVRANDAO" W256
ran
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. Read b => [Char] -> b -> IO b
getWord [Char]
"DAPP_TEST_CHAINID" W256
99