diff --git a/src/hevm/hevm-cli/hevm-cli.hs b/src/hevm/hevm-cli/hevm-cli.hs index 2713de7e9..761b457c2 100644 --- a/src/hevm/hevm-cli/hevm-cli.hs +++ b/src/hevm/hevm-cli/hevm-cli.hs @@ -36,11 +36,12 @@ import EVM.Types hiding (word) import EVM.UnitTest (UnitTestOptions, coverageReport, coverageForUnitTestContract) import EVM.UnitTest (runUnitTestContract) import EVM.UnitTest (getParametersFromEnvironmentVariables, testNumber) -import EVM.Dapp (findUnitTests, dappInfo, DappInfo, emptyDapp) +import EVM.Dapp (findUnitTests, dappInfo, DappInfo(..), emptyDapp) import EVM.Format (showTraceTree, showTree', renderTree, showBranchInfoWithAbi, showLeafInfo) import EVM.RLP (rlpdecode) import qualified EVM.Patricia as Patricia import Data.Map (Map) +import System.Directory (doesFileExist) import qualified EVM.Facts as Facts import qualified EVM.Facts.Git as Git @@ -50,7 +51,7 @@ import GHC.IO.Encoding import GHC.Stack import Control.Concurrent.Async (async, waitCatch) import Control.Lens hiding (pre, passing) -import Control.Monad (void, when, forM_, unless) +import Control.Monad (void, when, forM_, unless, foldM) import Control.Monad.State.Strict (execStateT, liftIO) import Data.ByteString (ByteString) import Data.List (intercalate, isSuffixOf) @@ -71,6 +72,7 @@ import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON import Data.Aeson (FromJSON (..), (.:)) import Data.Aeson.Lens hiding (values) +import Codec.Serialise (serialise, deserialiseOrFail, DeserialiseFailure(..)) import qualified Data.Vector as V import qualified Data.ByteString.Lazy as Lazy @@ -171,6 +173,8 @@ data Command w , debug :: w ::: Bool "Run interactively" , jsontrace :: w ::: Bool "Print json trace output at every step" , fuzzRuns :: w ::: Maybe Int "Number of times to run fuzz tests" + , mutations :: w ::: Maybe Int "Percentage of fuzz runs that should mutate a previous input vs randomly generating new inputs (default: 50)" + , corpus :: w ::: Maybe FilePath "Path to the location where the corpus of test inputs should be stored (default: .hevm.corpus)" , replay :: w ::: Maybe (Text, ByteString) "Custom fuzz case to run/debug" , rpc :: w ::: Maybe URL "Fetch state from a remote node" , verbose :: w ::: Maybe Int "Append call trace: {1} failures {2} all" @@ -291,6 +295,12 @@ unitTestOptions cmd testFile = do , EVM.UnitTest.vmModifier = vmModifier , EVM.UnitTest.testParams = params , EVM.UnitTest.dapp = srcInfo + , EVM.UnitTest.corpus = fromMaybe ".hevm.corpus" (corpus cmd) + , EVM.UnitTest.mutations = case mutations cmd of + Nothing -> 50 + Just x -> if x > 100 + then error "Mutations cannot be greater than 100" + else x } main :: IO () @@ -379,10 +389,21 @@ findJsonFile Nothing = do dappTest :: UnitTestOptions -> String -> Maybe String -> Query () dappTest opts solcFile cache = do out <- liftIO $ readSolc solcFile + let dappInfo' = EVM.UnitTest.dapp opts + corpusPath = (_dappRoot dappInfo') <> "/" <> (EVM.UnitTest.corpus opts) + initalCorpus <- liftIO $ doesFileExist corpusPath >>= \case + True -> liftIO $ (LazyByteString.readFile corpusPath) >>= \v -> case deserialiseOrFail v of + Left (DeserialiseFailure _ msg) -> error $ "unable to parse corpus: " <> msg + Right a -> pure a + False -> pure mempty + case out of Just (contractMap, _) -> do let unitTests = findUnitTests (EVM.UnitTest.match opts) $ Map.elems contractMap - results <- concatMapM (runUnitTestContract opts contractMap) unitTests + (finalCorpus, results) <- foldM (\(corpus, results) test -> do + (corpus', results') <- runUnitTestContract opts corpus contractMap test + pure (corpus', results <> results') + ) (initalCorpus, mempty) unitTests let (passing, vms) = unzip results case cache of Nothing -> @@ -394,6 +415,7 @@ dappTest opts solcFile cache = do in liftIO $ Git.saveFacts (Git.RepoAt path) (Facts.cacheFacts cache') + liftIO $ LazyByteString.writeFile (EVM.UnitTest.corpus opts) (serialise finalCorpus) liftIO $ unless (and passing) exitFailure Nothing -> error ("Failed to read Solidity JSON for `" ++ solcFile ++ "'") @@ -757,7 +779,7 @@ vmFromCommand cmd = do , EVM.vmoptChainId = word chainid 1 , EVM.vmoptCreate = create cmd , EVM.vmoptStorageModel = ConcreteS - , EVM.vmoptTxAccessList = mempty -- TODO: support me soon + , EVM.vmoptTxAccessList = mempty -- TODO: support me soon } word f def = fromMaybe def (f cmd) addr f def = fromMaybe def (f cmd) diff --git a/src/hevm/hevm.cabal b/src/hevm/hevm.cabal index 9f3717d22..a4d80f203 100644 --- a/src/hevm/hevm.cabal +++ b/src/hevm/hevm.cabal @@ -63,6 +63,7 @@ library EVM.Types, EVM.UnitTest, EVM.VMTest + EVM.Mutate other-modules: Paths_hevm autogen-modules: @@ -80,7 +81,7 @@ library install-includes: ethjet/tinykeccak.h, ethjet/ethjet.h, ethjet/ethjet-ff.h, ethjet/blake2.h build-depends: - QuickCheck >= 2.13.2 && < 2.15, + QuickCheck >= 2.13.2 && < 2.14, Decimal == 0.5.1, containers >= 0.6.0 && < 0.7, deepseq >= 1.4.4 && < 1.5, @@ -128,7 +129,9 @@ library witherable >= 0.3.5 && < 0.4, wreq >= 0.5.3 && < 0.6, regex-tdfa >= 1.2.3 && < 1.4, - base >= 4.9 && < 5 + base >= 4.9 && < 5, + ListLike >= 4.7.2 && < 4.8, + serialise >= 0.2.3.0 && < 0.3 hs-source-dirs: src default-language: @@ -172,6 +175,7 @@ executable hevm containers, cryptonite, data-dword, + serialise, deepseq, directory, filepath, @@ -210,6 +214,8 @@ test-suite test build-depends: HUnit >= 1.6, QuickCheck, + aeson, + blake3, base, base16-bytestring, binary, @@ -223,6 +229,8 @@ test-suite test tasty >= 1.0, tasty-hunit >= 0.10, tasty-quickcheck >= 0.9, + quickcheck-text, text, vector, + serialise, sbv diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index a0668e4d5..47d7d92a4 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -27,7 +27,7 @@ import EVM.FeeSchedule (FeeSchedule (..)) import Options.Generic as Options import qualified EVM.Precompiled -import Control.Lens hiding (op, (:<), (|>), (.>)) +import Control.Lens hiding (op, (:<), (|>), (.>), elements) import Control.Monad.State.Strict hiding (state) import Data.ByteString (ByteString) @@ -286,7 +286,7 @@ data SubState = SubState data ContractCode = InitCode Buffer -- ^ "Constructor" code, during contract creation | RuntimeCode Buffer -- ^ "Instance" code, after contract creation - deriving (Show) + deriving (Show, Generic) -- runtime err when used for symbolic code instance Eq ContractCode where @@ -436,14 +436,14 @@ currentContract vm = -- * Data constructors makeVm :: VMOpts -> VM -makeVm o = +makeVm o = let txaccessList = vmoptTxAccessList o txorigin = vmoptOrigin o txtoAddr = vmoptAddress o initialAccessedAddrs = fromList $ [txorigin, txtoAddr] ++ [1..9] ++ (Map.keys txaccessList) initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList) touched = if vmoptCreate o then [txorigin] else [txorigin, txtoAddr] - in + in VM { _result = Nothing , _frames = mempty @@ -1586,8 +1586,8 @@ makeUnique sw@(S w val) cont = case maybeLitWord sw of Unique a -> do assign result Nothing cont (C w $ fromSizzle a) - InconsistentU -> vmError $ DeadPath - TimeoutU -> vmError $ SMTTimeout + InconsistentU -> vmError DeadPath + TimeoutU -> vmError SMTTimeout Multiple -> vmError $ NotUnique w Just a -> cont a @@ -2123,7 +2123,7 @@ create self this xGas' xValue xs newAddr initCode = do then do assign (state . stack) (0 : xs) assign (state . returndata) mempty - pushTrace $ ErrorTrace $ CallDepthLimitReached + pushTrace $ ErrorTrace CallDepthLimitReached next else if collision $ view (env . contracts . at newAddr) vm0 then burn xGas $ do @@ -2283,7 +2283,7 @@ finishFrame how = do -- In other words, we special case address 0x03 and keep it in the set of touched accounts during revert touched <- use (tx . substate . touchedAccounts) - + let substate'' = over touchedAccounts (maybe id cons (find ((==) 3) touched)) substate' revertContracts = assign (env . contracts) reversion diff --git a/src/hevm/src/EVM/ABI.hs b/src/hevm/src/EVM/ABI.hs index f04112ce0..30a00ed10 100644 --- a/src/hevm/src/EVM/ABI.hs +++ b/src/hevm/src/EVM/ABI.hs @@ -63,7 +63,7 @@ import Data.Binary.Get (Get, runGet, runGetOrFail, label, getWord8, getWord32 import Data.Binary.Put (Put, runPut, putWord8, putWord32be) import Data.Bits (shiftL, shiftR, (.&.)) import Data.ByteString (ByteString) -import Data.DoubleWord (Word256, Int256, signedWord) +import Data.DoubleWord (Word256, Word128, Word160, Int128, Int256, signedWord) import Data.Functor (($>)) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8') @@ -76,6 +76,8 @@ import GHC.Generics import Test.QuickCheck hiding ((.&.), label) import Text.ParserCombinators.ReadP import Control.Applicative +import Data.Aeson +import Codec.Serialise (Serialise(..)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as Char8 @@ -99,6 +101,13 @@ data AbiValue | AbiTuple (Vector AbiValue) deriving (Read, Eq, Ord, Generic) +instance Serialise AbiValue +instance Serialise Int256 +instance Serialise Int128 +instance Serialise Addr +instance Serialise Word160 +instance Serialise AbiType + -- | Pretty-print some 'AbiValue'. instance Show AbiValue where show (AbiUInt _ n) = show n @@ -134,6 +143,10 @@ data AbiType | AbiTupleType (Vector AbiType) deriving (Read, Eq, Ord, Generic) +instance ToJSON AbiType +instance FromJSON AbiType + + instance Show AbiType where show = Text.unpack . abiTypeSolidity @@ -147,6 +160,15 @@ data Indexed = Indexed | NotIndexed data Event = Event Text Anonymity [(AbiType, Indexed)] deriving (Show, Ord, Eq, Generic) +instance ToJSON Anonymity +instance FromJSON Anonymity + +instance ToJSON Indexed +instance FromJSON Indexed + +instance ToJSON Event +instance FromJSON Event + abiKind :: AbiType -> AbiKind abiKind = \case AbiBytesDynamicType -> Dynamic diff --git a/src/hevm/src/EVM/Dev.hs b/src/hevm/src/EVM/Dev.hs index dec029f65..2c494c18e 100644 --- a/src/hevm/src/EVM/Dev.hs +++ b/src/hevm/src/EVM/Dev.hs @@ -26,6 +26,7 @@ import Options.Generic import Data.SBV.Trans.Control import Data.Maybe (fromMaybe) import Control.Monad.State.Strict (execStateT) +import Control.Monad (foldM) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as LazyByteString @@ -72,12 +73,17 @@ ghciTest root path statePath = , vmModifier = loadFacts , dapp = emptyDapp , testParams = params + , mutations = 50 + , corpus = ".hevm.corpus" } readSolc path >>= \case Just (contractMap, _) -> do let unitTests = findAllUnitTests (Map.elems contractMap) - results <- runSMT $ query $ concatMapM (runUnitTestContract opts contractMap) unitTests + (_, results) <- runSMT $ query $ foldM (\(c, r) t -> do + (c', r') <- runUnitTestContract opts c contractMap t + pure (c', r <> r') + ) mempty unitTests let (passing, _) = unzip results pure passing @@ -129,6 +135,8 @@ ghciTty root path statePath = , vmModifier = loadFacts , dapp = emptyDapp , testParams = params + , mutations = 50 + , corpus = ".hevm.corpus" } EVM.TTY.main testOpts root path diff --git a/src/hevm/src/EVM/Facts.hs b/src/hevm/src/EVM/Facts.hs index 1974f67f9..f7da994d7 100644 --- a/src/hevm/src/EVM/Facts.hs +++ b/src/hevm/src/EVM/Facts.hs @@ -39,6 +39,7 @@ import EVM (VM, Contract, Cache) import EVM.Symbolic (litWord, forceLit) import EVM (balance, nonce, storage, bytecode, env, contracts, contract, state, cache, fetched) import EVM.Types (Addr, Word, SymWord, Buffer(..)) +import EVM.UnitTest (Corpus) import qualified EVM @@ -71,10 +72,10 @@ default (ASCII) -- Note that Haskell allows this kind of union of records. -- It's convenient here, but typically avoided. data Fact - = BalanceFact { addr :: Addr, what :: Word } - | NonceFact { addr :: Addr, what :: Word } - | StorageFact { addr :: Addr, what :: Word, which :: Word } - | CodeFact { addr :: Addr, blob :: ByteString } + = BalanceFact { addr :: Addr, what :: Word } + | NonceFact { addr :: Addr, what :: Word } + | StorageFact { addr :: Addr, what :: Word, which :: Word } + | CodeFact { addr :: Addr, blob :: ByteString } deriving (Eq, Show) -- A fact path means something like "/0123...abc/storage/0x1", @@ -113,13 +114,13 @@ instance AsASCII ByteString where contractFacts :: Addr -> Contract -> [Fact] contractFacts a x = case view bytecode x of - ConcreteBuffer b -> + ConcreteBuffer b -> storageFacts a x ++ [ BalanceFact a (view balance x) , NonceFact a (view nonce x) , CodeFact a b ] - SymbolicBuffer b -> + SymbolicBuffer _ -> -- here simply ignore storing the bytecode storageFacts a x ++ [ BalanceFact a (view balance x) diff --git a/src/hevm/src/EVM/Mutate.hs b/src/hevm/src/EVM/Mutate.hs new file mode 100644 index 000000000..671a02ad6 --- /dev/null +++ b/src/hevm/src/EVM/Mutate.hs @@ -0,0 +1,116 @@ +{- + Mutators for abi values, adapted from echidna +-} +module EVM.Mutate where + +import Data.Bifunctor (second) +import Data.Bool (bool) +import Test.QuickCheck.Gen (Gen, choose, frequency) +import Data.DoubleWord (Int256, Word256) +import Test.QuickCheck.Arbitrary (arbitrary) + +import EVM.ABI + +import Control.Monad (replicateM) +import qualified Data.ByteString as BS +import qualified Data.Vector as V +import qualified Data.ListLike as LL + +-- | Given an 'AbiValue', generate a random \"similar\" value of the same 'AbiType'. +mutateAbiValue :: AbiValue -> Gen AbiValue +mutateAbiValue (AbiUInt n x) = frequency [(1, fixAbiUInt n <$> mutateNum x), (9, pure $ AbiUInt n x)] +mutateAbiValue (AbiInt n x) = frequency [(1, fixAbiInt n <$> mutateNum x), (9, pure $ AbiInt n x)] + +mutateAbiValue (AbiAddress x) = return $ AbiAddress x +mutateAbiValue (AbiBool _) = genAbiValue AbiBoolType +mutateAbiValue (AbiBytes n b) = do fs <- replicateM n arbitrary + xs <- mutateLL (Just n) (BS.pack fs) b + return (AbiBytes n xs) + +mutateAbiValue (AbiBytesDynamic b) = AbiBytesDynamic <$> mutateLL Nothing mempty b +mutateAbiValue (AbiString b) = AbiString <$> mutateLL Nothing mempty b +mutateAbiValue (AbiArray n t l) = do fs <- replicateM n $ genAbiValue t + xs <- mutateLL (Just n) (V.fromList fs) l + return (AbiArray n t xs) + +mutateAbiValue (AbiArrayDynamic t l) = AbiArrayDynamic t <$> mutateLL Nothing mempty l +mutateAbiValue (AbiTuple v) = AbiTuple <$> traverse mutateAbiValue v + + +-- | Mutate a list-like data structure using a list of mutators +mutateLL :: LL.ListLike f i + => Maybe Int -- ^ Required size for the mutated list-like value (or Nothing if there are no constrains) + -> f -- ^ Randomly generated list-like value to complement the mutated list, if it is shorter than the requested size + -> f -- ^ List-like value to mutate + -> Gen f +mutateLL mn fs vs = do + f <- genMutator + xs <- f vs + return $ maybe xs (`LL.take` (xs <> fs)) mn + +-- | A list of mutators to randomly select to perform a mutation of list-like values +genMutator :: LL.ListLike f i => Gen (f -> Gen f) +genMutator = frequency . fmap (second pure) $ [(1, return), (10, expandRandList), (10, deleteRandList), (10, swapRandList)] + +-- | +expandRandList :: LL.ListLike f i => f -> Gen f +expandRandList xs + | l == 0 = return xs + | l >= 32 = return xs + | otherwise = do + k <- choose (0, l - 1) + t <- choose (1, min 32 l) + return $ expandAt xs k t + where l = LL.length xs + +expandAt :: LL.ListLike f i => f -> Int -> Int -> f +expandAt xs k t = + case LL.uncons xs of + Nothing -> xs + Just (y,ys) -> if k == 0 + then LL.replicate t y <> ys + else LL.cons y (expandAt ys (k - 1) t) + +-- | Delete a random element from the `ListLike` f +deleteRandList :: LL.ListLike f i => f -> Gen f +deleteRandList xs = + if LL.null xs + then return xs + else do + k <- choose (0, LL.length xs - 1) + return $ deleteAt k xs + +deleteAt :: LL.ListLike f i => Int -> f -> f +deleteAt n f = LL.take n f <> LL.drop (n+1) f + +-- | Given a `ListLike` f, swap two random elements +swapRandList :: LL.ListLike f i => f -> Gen f +swapRandList xs = + if LL.null xs + then return xs + else do + i <- choose (0, LL.length xs - 1) + j <- choose (0, LL.length xs - 1) + return $ if i == j then xs else swapAt xs (min i j) (max i j) + +-- taken from https://stackoverflow.com/questions/30551033/swap-two-elements-in-a-list-by-its-indices/30551130#30551130 +swapAt :: LL.ListLike f i => f -> Int -> Int -> f +swapAt xs i j = left <> LL.cons elemJ middle <> LL.cons elemI right + where elemI = xs `LL.index` i + elemJ = xs `LL.index` j + left = LL.take i xs + middle = LL.take (j - i - 1) (LL.drop (i + 1) xs) + right = LL.drop (j + 1) xs + + +-- | Given an 'Integral' number n, get a random number in [0,2n]. +mutateNum :: Integral a => a -> Gen a +mutateNum x = bool (x +) (x -) <$> arbitrary <*> (fromInteger <$> (choose (0, toInteger x))) + +-- | Force `x` to be in the range of a uint of size `n` +fixAbiUInt :: Int -> Word256 -> AbiValue +fixAbiUInt n x = AbiUInt n (x `mod` ((2 ^ n) - 1)) + +-- | Force `x` to be in the range of an int of size `n` +fixAbiInt :: Int -> Int256 -> AbiValue +fixAbiInt n x = AbiInt n (x `mod` 2 ^ (n - 1)) diff --git a/src/hevm/src/EVM/Solidity.hs b/src/hevm/src/EVM/Solidity.hs index 2f29bae0d..b0d36bb0d 100644 --- a/src/hevm/src/EVM/Solidity.hs +++ b/src/hevm/src/EVM/Solidity.hs @@ -97,7 +97,7 @@ data StorageItem = StorageItem { _type :: SlotType, _offset :: Int, _slot :: Int - } deriving (Show, Eq) + } deriving (Show, Eq, Ord, Generic) data SlotType -- Note that mapping keys can only be elementary; @@ -105,7 +105,7 @@ data SlotType = StorageMapping (NonEmpty AbiType) AbiType | StorageValue AbiType -- | StorageArray AbiType - deriving Eq + deriving (Eq, Ord, Generic) instance Show SlotType where show (StorageValue t) = show t @@ -141,7 +141,7 @@ data SolcContract = SolcContract , _storageLayout :: Maybe (Map Text StorageItem) , _runtimeSrcmap :: Seq SrcMap , _creationSrcmap :: Seq SrcMap - } deriving (Show, Eq, Generic) + } deriving (Show, Eq, Generic, Ord) data Method = Method { _methodOutput :: [(Text, AbiType)] @@ -159,7 +159,7 @@ data SourceCache = SourceCache data Reference = Reference { _refStart :: Int, _refLength :: Int - } deriving (Show, Eq) + } deriving (Show, Eq, Ord) instance FromJSON Reference where parseJSON (Object v) = Reference diff --git a/src/hevm/src/EVM/Types.hs b/src/hevm/src/EVM/Types.hs index 9cdc48af4..c857b4b31 100644 --- a/src/hevm/src/EVM/Types.hs +++ b/src/hevm/src/EVM/Types.hs @@ -29,6 +29,8 @@ import Data.Maybe (fromMaybe) import Numeric (readHex, showHex) import Options.Generic import Control.Arrow ((>>>)) +import Test.QuickCheck (Arbitrary(..), choose) +import Codec.Serialise (Serialise(..)) import qualified Data.ByteArray as BA import qualified Data.Aeson as JSON @@ -57,6 +59,15 @@ newtype W256 = W256 Word256 , Bits, FiniteBits, Bounded, Generic ) +instance Serialise W256 +instance Serialise Word256 +instance Serialise Word128 + +instance Arbitrary W256 where + arbitrary = do + v <- choose (0, 2 ^ (256 :: Integer)) + pure $ W256 (fromInteger v) + data Word = C Whiff W256 --maybe to remove completely in the future instance Show Word where @@ -138,6 +149,9 @@ instance Read ByteStringS where instance JSON.ToJSON ByteStringS where toJSON = JSON.String . Text.pack . show +instance JSON.FromJSON ByteStringS where + parseJSON = withText "ByteStringS" $ pure . read . Text.unpack + -- | Symbolic words of 256 bits, possibly annotated with additional -- "insightful" information data SymWord = S Whiff (SWord 256) @@ -269,6 +283,16 @@ instance Show Whiff where newtype Addr = Addr { addressWord160 :: Word160 } deriving (Num, Integral, Real, Ord, Enum, Eq, Bits, Generic) +instance ToJSON Addr where + toJSON = String . Text.pack . show + +instance FromJSON Addr where + parseJSON v = do + s <- Text.unpack <$> parseJSON v + case reads s of + [(x, "")] -> return x + _ -> fail $ "invalid address (" ++ s ++ ")" + newtype SAddr = SAddr { saddressWord160 :: SWord 160 } deriving (Num) @@ -349,6 +373,12 @@ instance Read W256 where instance Show W256 where showsPrec _ s = ("0x" ++) . showHex s +instance ToJSONKey W256 where + toJSONKey = JSON.toJSONKeyText w256Text + +w256Text :: W256 -> Text +w256Text = Text.pack . show + instance JSON.ToJSON W256 where toJSON = JSON.String . Text.pack . show @@ -387,13 +417,6 @@ instance FromJSON W256 where [(x, "")] -> return x _ -> fail $ "invalid hex word (" ++ s ++ ")" -instance FromJSON Addr where - parseJSON v = do - s <- Text.unpack <$> parseJSON v - case reads s of - [(x, "")] -> return x - _ -> fail $ "invalid address (" ++ s ++ ")" - #if MIN_VERSION_aeson(1, 0, 0) instance FromJSONKey W256 where diff --git a/src/hevm/src/EVM/UnitTest.hs b/src/hevm/src/EVM/UnitTest.hs index 17bc60425..7e8e3cc94 100644 --- a/src/hevm/src/EVM/UnitTest.hs +++ b/src/hevm/src/EVM/UnitTest.hs @@ -1,6 +1,7 @@ {-# Language LambdaCase #-} {-# Language DataKinds #-} {-# Language ImplicitParams #-} +{-# LANGUAGE FlexibleInstances #-} module EVM.UnitTest where @@ -18,6 +19,7 @@ import EVM.Solidity import EVM.SymExec import EVM.Types import EVM.Transaction (initTx) +import EVM.Mutate (mutateAbiValue) import qualified EVM.Fetch import qualified EVM.FeeSchedule as FeeSchedule @@ -43,12 +45,13 @@ import Data.SBV.Control (CheckSatResult(..), checkSat) import Data.Decimal (DecimalRaw(..)) import Data.Either (isRight, lefts) import Data.Foldable (toList) -import Data.Map (Map) +import Data.Map hiding (mapMaybe, toList, map, filter, null, take) import Data.Maybe (fromMaybe, catMaybes, fromJust, isJust, fromMaybe, mapMaybe) import Data.Text (isPrefixOf, stripSuffix, intercalate, Text, pack, unpack) import Data.Text.Encoding (encodeUtf8) import System.Environment (lookupEnv) import System.IO (hFlush, stdout) +import GHC.Generics (Generic) import qualified Control.Monad.Par.Class as Par import qualified Data.ByteString as BS @@ -81,6 +84,8 @@ data UnitTestOptions = UnitTestOptions , vmModifier :: VM -> VM , dapp :: DappInfo , testParams :: TestVMParams + , mutations :: Int + , corpus :: FilePath } data TestVMParams = TestVMParams @@ -101,6 +106,12 @@ data TestVMParams = TestVMParams , testChainId :: W256 } +-- | For each tuple of (contract, method) we store the calldata required to +-- reach each known path in the method +type Corpus = Map (W256,Text) (Map [(W256, Int)] AbiValue) + +data FuzzResult = Pass | Fail VM String + defaultGasForCreating :: W256 defaultGasForCreating = 0xffffffffffff @@ -191,23 +202,100 @@ checkFailures UnitTestOptions { .. } method bailed = do in pure (shouldFail == failed) _ -> error "internal error: unexpected failure code" --- | Randomly generates the calldata arguments and runs the test -fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property -fuzzTest opts sig types vm = forAllShow (genAbiValue (AbiTupleType $ Vector.fromList types)) (show . ByteStringS . encodeAbiValue) - $ \args -> ioProperty $ - fst <$> runStateT (EVM.Stepper.interpret (oracle opts) (runUnitTest opts sig args)) vm +-- | Either generates the calldata by mutating an example from the corpus, or synthesizes a random example +genWithCorpus :: UnitTestOptions -> Corpus -> W256 -> Text -> [AbiType] -> Gen AbiValue +genWithCorpus opts corpus codeHash sig tps = do + case Map.lookup (codeHash, sig) corpus of + Nothing -> genAbiValue (AbiTupleType $ Vector.fromList tps) + Just examples -> frequency + [ (mutations opts, Test.QuickCheck.elements (Map.elems examples) >>= mutateAbiValue) + , (100 - (mutations opts), genAbiValue (AbiTupleType $ Vector.fromList tps)) + ] + +-- | Randomly generates the calldata arguments and runs the test, updates the corpus with a new example if we explored a new path +fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> StateT Corpus IO FuzzResult +fuzzTest opts sig types vm = do + let codeHash' = _codehash . fromJust $ currentContract vm + corpus <- get + args <- liftIO . generate $ genWithCorpus opts corpus codeHash' sig types + (res, (vm', trace')) <- liftIO $ runStateT (interpretWithTraceId opts (runUnitTest opts sig args)) (vm, []) + modify $ updateCorpus (codeHash', sig) trace' args + if res + then pure Pass + else pure $ Fail vm' (show . ByteStringS . encodeAbiValue $ args) + where + updateCorpus k1 k2 v c = case Map.lookup k1 c of + Nothing -> Map.insert k1 (Map.insert k2 v mempty) c + Just m' -> Map.insert k1 (Map.insert k2 v m') c + +type TraceIdState = (VM, [(W256, Int)]) + +-- | This interpreter is similar to interpretWithCoverage, except instead of +-- collecting the full trace, we instead return a hash of the trace. This +-- avoids the overhead associated with the MultiSet used in interpretWithCoverage +interpretWithTraceId + :: UnitTestOptions + -> Stepper a + -> StateT TraceIdState IO a +interpretWithTraceId opts = + eval . Operational.view + + where + eval + :: Operational.ProgramView Stepper.Action a + -> StateT TraceIdState IO a + + eval (Operational.Return x) = + pure x + + eval (action Operational.:>>= k) = + case action of + Stepper.Exec -> + execWithTraceId >>= interpretWithTraceId opts . k + Stepper.Run -> + runWithTraceId >>= interpretWithTraceId opts . k + Stepper.Wait q -> do + m <- liftIO (oracle opts q) + zoom _1 (State.state (runState m)) >> interpretWithTraceId opts (k ()) + Stepper.Ask _ -> + error "cannot make choice in this interpreter" + Stepper.EVM m -> + zoom _1 (State.state (runState m)) >>= interpretWithTraceId opts . k + +execWithTraceId :: StateT TraceIdState IO VMResult +execWithTraceId = do _ <- runWithTraceId + fromJust <$> use (_1 . result) + +runWithTraceId :: StateT TraceIdState IO VM +runWithTraceId = do + -- This is just like `exec` except for every instruction evaluated, + -- we also updae a hash accumulator for each instruction visited + vm0 <- use _1 + case view result vm0 of + Nothing -> do + vm1 <- zoom _1 (State.state (runState exec1) >> get) + zoom _2 (modify (\acc -> loc vm1 : acc)) + runWithTraceId + Just _ -> pure vm0 + where + loc vm = + case currentContract vm of + Nothing -> + error "internal error: why no contract?" + Just c -> (view codehash c, fromMaybe (error "internal error: op ix") (vmOpIx vm)) tick :: Text -> IO () tick x = Text.putStr x >> hFlush stdout -- | This is like an unresolved source mapping. data OpLocation = OpLocation - { srcCode :: ContractCode - , srcOpIx :: Int - } deriving (Show, Eq, Ord) + { srcCode :: ContractCode + , codeHash :: W256 + , srcOpIx :: Int + } deriving (Show, Eq, Ord, Generic) srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap -srcMapForOpLocation dapp (OpLocation hash opIx) = srcMap dapp hash opIx +srcMapForOpLocation dapp (OpLocation code' _ opIx) = srcMap dapp code' opIx type CoverageState = (VM, MultiSet OpLocation) @@ -219,6 +307,7 @@ currentOpLocation vm = Just c -> OpLocation (view contractcode c) + (view codehash c) (fromMaybe (error "internal error: op ix") (vmOpIx vm)) execWithCoverage :: StateT CoverageState IO VMResult @@ -294,7 +383,7 @@ coverageReport dapp cov = linesByName :: Map Text (Vector ByteString) linesByName = Map.fromList $ zipWith - (\(name, _) lines -> (name, lines)) + (\(name, _) lines' -> (name, lines')) (view sourceFiles sources) (view sourceLines sources) @@ -354,11 +443,12 @@ coverageForUnitTestContract runUnitTestContract :: UnitTestOptions + -> Corpus -> Map Text SolcContract -> (Text, [(Test, [AbiType])]) - -> SBV.Query [(Bool, VM)] + -> SBV.Query (Corpus, [(Bool, VM)]) runUnitTestContract - opts@(UnitTestOptions {..}) contractMap (name, testSigs) = do + opts@(UnitTestOptions {..}) corpus' contractMap (name, testSigs) = do -- Print a header liftIO $ putStrLn $ "Running " ++ show (length testSigs) ++ " tests for " @@ -385,20 +475,20 @@ runUnitTestContract Text.putStrLn "\x1b[31m[BAIL]\x1b[0m setUp() " tick "\n" tick $ failOutput vm1 opts "setUp()" - pure [(False, vm1)] + pure (corpus', [(False, vm1)]) Just (VMSuccess _) -> do let - runCache :: ([(Either Text Text, VM)], VM) -> (Test, [AbiType]) - -> SBV.Query ([(Either Text Text, VM)], VM) - runCache (results, vm) (test, types) = do - (t, r, vm') <- runTest opts vm (test, types) + runCache :: ([(Either Text Text, VM)], VM, Corpus) -> (Test, [AbiType]) + -> SBV.Query ([(Either Text Text, VM)], VM, Corpus) + runCache (results, vm, corp) (test, types) = do + (t, r, vm', corp') <- runTest opts vm corp (test, types) liftIO $ Text.putStrLn t let vmCached = vm & set (cache . fetched) (view (cache . fetched) vm') - pure (((r, vm'): results), vmCached) + pure (((r, vm'): results), vmCached, corp') -- Run all the test cases and print their status updates, -- accumulating the vm cache throughout - (details, _) <- foldM runCache ([], vm1) testSigs + (details, _, finalCorpus) <- foldM runCache ([], vm1, corpus') testSigs let running = [x | (Right x, _) <- details] let bailing = [x | (Left x, _) <- details] @@ -408,20 +498,21 @@ runUnitTestContract tick (Text.unlines (filter (not . Text.null) running)) tick (Text.unlines (filter (not . Text.null) bailing)) - pure [(isRight r, vm) | (r, vm) <- details] + pure (finalCorpus, [(isRight r, vm) | (r, vm) <- details]) -runTest :: UnitTestOptions -> VM -> (Test, [AbiType]) -> SBV.Query (Text, Either Text Text, VM) -runTest opts@UnitTestOptions{..} vm (ConcreteTest testName, []) = liftIO $ runOne opts vm testName emptyAbi -runTest opts@UnitTestOptions{..} vm (ConcreteTest testName, types) = liftIO $ case replay of - Nothing -> - fuzzRun opts vm testName types +runTest :: UnitTestOptions -> VM -> Corpus -> (Test, [AbiType]) -> SBV.Query (Text, Either Text Text, VM, Corpus) +runTest opts@UnitTestOptions{..} vm corpus' (ConcreteTest testName, []) = liftIO $ extend3 corpus' <$> runOne opts vm testName emptyAbi +runTest opts@UnitTestOptions{..} vm corpus' (ConcreteTest testName, types) = liftIO $ case replay of + Nothing -> fuzzRun opts vm corpus' testName types Just (sig, callData) -> if sig == testName - then runOne opts vm testName $ - decodeAbiValue (AbiTupleType (Vector.fromList types)) callData - else fuzzRun opts vm testName types -runTest opts vm (SymbolicTest testName, types) = symRun opts vm testName types + then extend3 corpus' <$> (runOne opts vm testName $ decodeAbiValue (AbiTupleType (Vector.fromList types)) callData) + else fuzzRun opts vm corpus' testName types +runTest opts vm corpus' (SymbolicTest testName, types) = extend3 corpus' <$> (symRun opts vm testName types) + +extend3:: d -> (a, b, c) -> (a, b, c, d) +extend3 d (a, b, c) = (a, b, c, d) -- | Define the thread spawner for normal test cases runOne :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Text, Either Text Text, VM) @@ -461,43 +552,37 @@ runOne opts@UnitTestOptions{..} vm testName args = do ) -- | Define the thread spawner for property based tests -fuzzRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM) -fuzzRun opts@UnitTestOptions{..} vm testName types = do - let args = Args{ replay = Nothing - , maxSuccess = fuzzRuns - , maxDiscardRatio = 10 - , maxSize = 100 - , chatty = isJust verbose - , maxShrinks = maxBound - } - quickCheckWithResult args (fuzzTest opts testName types vm) >>= \case - Success numTests _ _ _ _ _ -> +fuzzRun :: UnitTestOptions -> VM -> Corpus -> Text -> [AbiType] -> IO (Text, Either Text Text, VM, Corpus) +fuzzRun opts@UnitTestOptions{..} vm corpus' testName types = do + + (res, finalCorpus) <- foldM (\(res, corp) _ -> case res of + Pass -> runStateT (fuzzTest opts testName types vm) corp + Fail {} -> pure (res, corp) + ) (Pass, corpus') [0..fuzzRuns] + + case res of + (Pass) -> pure ("\x1b[32m[PASS]\x1b[0m " - <> testName <> " (runs: " <> (pack $ show numTests) <> ")" + <> testName <> " (runs: " <> (pack . show $ fuzzRuns) <> ")" -- this isn't the post vm we actually want, as we -- can't retrieve the correct vm from quickcheck , Right (passOutput vm opts testName) , vm + , finalCorpus + ) + (Fail vm' cex) -> + pure ("\x1b[31m[FAIL]\x1b[0m " + <> testName <> ". Counterexample: " <> ppOutput + <> "\nRun:\n dapp test --replay '(\"" <> testName <> "\",\"" + <> (pack cex) <> "\")'\nto test this case again, or \n dapp debug --replay '(\"" + <> testName <> "\",\"" <> (pack cex) <> "\")'\nto debug it." + , Left (failOutput vm' opts testName) + , vm' + , finalCorpus ) - Failure _ _ _ _ _ _ _ _ _ _ failCase _ _ -> - let abiValue = decodeAbiValue (AbiTupleType (Vector.fromList types)) $ BSLazy.fromStrict $ hexText (pack $ concat failCase) - ppOutput = pack $ show abiValue - in do - -- Run the failing test again to get a proper trace - vm' <- execStateT (EVM.Stepper.interpret oracle (runUnitTest opts testName abiValue)) vm - pure ("\x1b[31m[FAIL]\x1b[0m " - <> testName <> ". Counterexample: " <> ppOutput - <> "\nRun:\n dapp test --replay '(\"" <> testName <> "\",\"" - <> (pack (concat failCase)) <> "\")'\nto test this case again, or \n dapp debug --replay '(\"" - <> testName <> "\",\"" <> (pack (concat failCase)) <> "\")'\nto debug it." - , Left (failOutput vm' opts testName) - , vm' - ) - _ -> pure ("\x1b[31m[OOPS]\x1b[0m " - <> testName - , Left (failOutput vm opts testName) - , vm - ) + where + abiValue = decodeAbiValue (AbiTupleType (Vector.fromList types)) $ BSLazy.fromStrict $ hexText (pack cex) + ppOutput = pack $ show abiValue -- | Define the thread spawner for symbolic tests -- TODO: return a list of VM's diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index b7689e794..ac505a2dc 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -3,7 +3,6 @@ {-# Language ScopedTypeVariables #-} {-# Language LambdaCase #-} {-# Language QuasiQuotes #-} -{-# Language TypeSynonymInstances #-} {-# Language FlexibleInstances #-} {-# Language GeneralizedNewtypeDeriving #-} {-# Language DataKinds #-} @@ -18,11 +17,12 @@ import Prelude hiding (fail) import qualified Data.Text as Text import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BS (fromStrict, toStrict) +import qualified Data.ByteString.Lazy as BS (fromStrict) import qualified Data.ByteString.Base16 as Hex import Test.Tasty import Test.Tasty.QuickCheck import Test.Tasty.HUnit +import Data.Text.Arbitrary () import Control.Monad.State.Strict (execState, runState) import Control.Lens hiding (List, pre, (.>)) @@ -38,15 +38,19 @@ import Data.SBV.Control import qualified Data.Map as Map import Data.Binary.Get (runGetOrFail) -import EVM hiding (Query) +import Data.Aeson (fromJSON, toJSON, Result(..)) +import Codec.Serialise (serialise, deserialise) + +import EVM hiding (Query, code, path) import EVM.SymExec import EVM.ABI import EVM.Exec import qualified EVM.Patricia as Patricia import EVM.Precompiled import EVM.RLP -import EVM.Solidity +import EVM.Solidity hiding (solc) import EVM.Types +import EVM.UnitTest instance MonadFail Query where fail = io . fail @@ -97,6 +101,17 @@ main = defaultMain $ testGroup "hevm" assertEqual "abi encoding mismatch" solidityEncoded (AbiBytesDynamic hevmEncoded) ] + , testGroup "Corpus Serialization" + + [ testProperty "AbiValue" $ do + val <- arbitrary :: Gen AbiValue + pure $ (deserialise . serialise $ val) == val + + , testProperty "Corpus" $ withMaxSuccess 20 $ do + val <- arbitrary :: Gen Corpus + pure $ (deserialise . serialise $ val) == val + ] + , testGroup "Precompiled contracts" [ testGroup "Example (reverse)" [ testCase "success" $ @@ -320,7 +335,7 @@ main = defaultMain $ testGroup "hevm" (Right _, vm) <- verifyContract c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre (Just post) case view (state . calldata . _1) vm of SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs - ConcreteBuffer bs -> error "unexpected" + ConcreteBuffer _ -> error "unexpected" let [AbiUInt 256 x, AbiUInt 256 y] = decodeAbiValues [AbiUIntType 256, AbiUIntType 256] bs assertEqual "Catch storage collisions" x y @@ -497,7 +512,7 @@ main = defaultMain $ testGroup "hevm" |] -- should find a counterexample Right _ <- runSMTWith cvc4 $ query $ fst <$> checkAssert c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] - putStrLn $ "found counterexample:" + putStrLn "found counterexample:" , @@ -520,7 +535,7 @@ main = defaultMain $ testGroup "hevm" aAddr = Addr 0x35D1b3F3D7966A1DFe207aa4514C12a259A0492B Just c <- solcRuntime "C" code Just a <- solcRuntime "A" code - Right cex <- runSMT $ query $ do + Right _ <- runSMT $ query $ do vm0 <- abstractVM (Just ("call_A()", [])) [] c SymbolicS store <- freshArray (show aAddr) Nothing let vm = vm0 @@ -529,7 +544,7 @@ main = defaultMain $ testGroup "hevm" (Map.insert aAddr (initialContract (RuntimeCode $ ConcreteBuffer a) & set EVM.storage (EVM.Symbolic [] store))) verify vm Nothing Nothing (Just checkAssertions) - putStrLn $ "found counterexample:" + putStrLn "found counterexample:" , testCase "calling unique contracts (read from storage)" $ do let code = @@ -549,11 +564,11 @@ main = defaultMain $ testGroup "hevm" } |] Just c <- solcRuntime "C" code - Right cex <- runSMT $ query $ do + Right _ <- runSMT $ query $ do vm0 <- abstractVM (Just ("call_A()", [])) [] c SymbolicS let vm = vm0 & set (state . callvalue) 0 verify vm Nothing Nothing (Just checkAssertions) - putStrLn $ "found counterexample:" + putStrLn "found counterexample:" , testCase "keccak concrete and sym agree" $ do @@ -572,14 +587,14 @@ main = defaultMain $ testGroup "hevm" vm0 <- abstractVM (Just ("kecc(uint256)", [AbiUIntType 256])) [] c SymbolicS let vm = vm0 & set (state . callvalue) 0 verify vm Nothing Nothing (Just checkAssertions) - putStrLn $ "found counterexample:" + putStrLn "found counterexample:" , testCase "safemath distributivity (yul)" $ do Left _ <- runSMTWith cvc4 $ query $ do let yulsafeDistributivity = hex "6355a79a6260003560e01c14156016576015601f565b5b60006000fd60a1565b603d602d604435600435607c565b6039602435600435607c565b605d565b6052604b604435602435605d565b600435607c565b141515605a57fe5b5b565b6000828201821115151560705760006000fd5b82820190505b92915050565b6000818384048302146000841417151560955760006000fd5b82820290505b92915050565b" vm <- abstractVM (Just ("distributivity(uint256,uint256,uint256)", [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] yulsafeDistributivity SymbolicS verify vm Nothing Nothing (Just checkAssertions) - putStrLn $ "Proven" + putStrLn "Proven" , testCase "safemath distributivity (sol)" $ do let code = @@ -602,7 +617,7 @@ main = defaultMain $ testGroup "hevm" Left _ <- runSMTWith z3 $ query $ do vm <- abstractVM (Just ("distributivity(uint256,uint256,uint256)", [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256])) [] c SymbolicS verify vm Nothing Nothing (Just checkAssertions) - putStrLn $ "Proven" + putStrLn "Proven" ] , testGroup "Equivalence checking" @@ -620,7 +635,7 @@ main = defaultMain $ testGroup "hevm" let aPrgm = hex "602060006000376000805160008114601d5760018114602457fe6029565b8191506029565b600191505b50600160015250" bPrgm = hex "6020600060003760005160008114601c5760028114602057fe6021565b6021565b5b506001600152" runSMTWith z3 $ query $ do - Right counterexample <- equivalenceCheck aPrgm bPrgm Nothing Nothing + Right _ <- equivalenceCheck aPrgm bPrgm Nothing Nothing return () ] @@ -753,4 +768,3 @@ bothM f (a, a') = do b <- f a b' <- f a' return (b, b') -