Coverage Guided / Mutation Based Fuzzing

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)

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

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

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

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
 

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)