Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Coverage Guided / Mutation Based Fuzzing #687

Draft
wants to merge 21 commits into
base: master
Choose a base branch
from
Draft
Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
21 commits
Select commit Hold shift + click to select a range
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
30 changes: 26 additions & 4 deletions src/hevm/hevm-cli/hevm-cli.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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

Expand Down Expand Up @@ -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"
Expand Down Expand Up @@ -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 ()
Expand Down Expand Up @@ -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 ->
Expand All @@ -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 ++ "'")
Expand Down Expand Up @@ -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)
Expand Down
12 changes: 10 additions & 2 deletions src/hevm/hevm.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -63,6 +63,7 @@ library
EVM.Types,
EVM.UnitTest,
EVM.VMTest
EVM.Mutate
other-modules:
Paths_hevm
autogen-modules:
Expand All @@ -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,
Expand Down Expand Up @@ -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:
Expand Down Expand Up @@ -172,6 +175,7 @@ executable hevm
containers,
cryptonite,
data-dword,
serialise,
deepseq,
directory,
filepath,
Expand Down Expand Up @@ -210,6 +214,8 @@ test-suite test
build-depends:
HUnit >= 1.6,
QuickCheck,
aeson,
blake3,
base,
base16-bytestring,
binary,
Expand All @@ -223,6 +229,8 @@ test-suite test
tasty >= 1.0,
tasty-hunit >= 0.10,
tasty-quickcheck >= 0.9,
quickcheck-text,
text,
vector,
serialise,
sbv
16 changes: 8 additions & 8 deletions src/hevm/src/EVM.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
24 changes: 23 additions & 1 deletion src/hevm/src/EVM/ABI.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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')
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -134,6 +143,10 @@ data AbiType
| AbiTupleType (Vector AbiType)
deriving (Read, Eq, Ord, Generic)

instance ToJSON AbiType
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think all these ToJSON/FromJSON instances are not neeeded anymore, they're just leftover from a time when I was serializing the corpus as json.

instance FromJSON AbiType


instance Show AbiType where
show = Text.unpack . abiTypeSolidity

Expand All @@ -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
Expand Down
10 changes: 9 additions & 1 deletion src/hevm/src/EVM/Dev.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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

Expand Down
13 changes: 7 additions & 6 deletions src/hevm/src/EVM/Facts.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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",
Expand Down Expand Up @@ -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)
Expand Down
Loading