diff --git a/lib/Echidna.hs b/lib/Echidna.hs index 2eabd85e2..64b84fe93 100644 --- a/lib/Echidna.hs +++ b/lib/Echidna.hs @@ -3,7 +3,7 @@ module Echidna where import Control.Concurrent (newChan) import Control.Monad.Catch (MonadThrow(..)) import Control.Monad.ST (RealWorld) -import Data.IORef (writeIORef, newIORef) +import Data.IORef (newIORef) import Data.List (find) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE @@ -13,25 +13,26 @@ import System.FilePath (()) import EVM (cheatCode) import EVM.ABI (AbiValue(AbiAddress)) -import EVM.Dapp (DappInfo(..), dappInfo) +import EVM.Dapp (dappInfo) import EVM.Fetch qualified -import EVM.Solidity (BuildOutput) +import EVM.Solidity (BuildOutput(..), Contracts(Contracts)) import EVM.Types hiding (Env) import Echidna.ABI import Echidna.Etheno (loadEtheno, extractFromEtheno) +import Echidna.Onchain as Onchain import Echidna.Output.Corpus import Echidna.SourceAnalysis.Slither import Echidna.Solidity import Echidna.Symbolic (forceAddr) -import Echidna.Test (createTests) import Echidna.Types.Campaign import Echidna.Types.Config import Echidna.Types.Random -import Echidna.Types.Signature import Echidna.Types.Solidity import Echidna.Types.Tx import Echidna.Types.World +import Echidna.Types.Test (EchidnaTest) +import Echidna.Types.Signature (ContractName) -- | This function is used to prepare, process, compile and initialize smart contracts for testing. -- It takes: @@ -45,17 +46,20 @@ import Echidna.Types.World -- * A list of Echidna tests to check -- * A prepopulated dictionary prepareContract - :: Env + :: EConfig -> NonEmpty FilePath + -> BuildOutput -> Maybe ContractName -> Seed - -> IO (VM Concrete RealWorld, World, GenDict) -prepareContract env solFiles specifiedContract seed = do - let solConf = env.cfg.solConf - contracts = Map.elems env.dapp.solcByName + -> IO (VM Concrete RealWorld, Env, GenDict) +prepareContract cfg solFiles buildOutput selectedContract seed = do + let solConf = cfg.solConf + (Contracts contractMap) = buildOutput.contracts + contracts = Map.elems contractMap - -- deploy contracts - (vm, funs, testNames, signatureMap) <- loadSpecified env specifiedContract contracts + mainContract <- selectMainContract solConf selectedContract contracts + tests <- mkTests solConf mainContract + signatureMap <- mkSignatureMap solConf mainContract contracts -- run processors slitherInfo <- runSlither (NE.head solFiles) solConf @@ -64,16 +68,14 @@ prepareContract env solFiles specifiedContract seed = do Just version -> throwM $ OutdatedSolcVersion version Nothing -> pure () - let - -- load tests - echidnaTests = createTests solConf.testMode - solConf.testDestruction - testNames - (forceAddr vm.state.contract) - funs + let world = mkWorld cfg.solConf signatureMap selectedContract slitherInfo contracts - world = mkWorld solConf signatureMap specifiedContract slitherInfo contracts + env <- mkEnv cfg buildOutput tests world + -- deploy contracts + vm <- loadSpecified env mainContract contracts + + let deployedAddresses = Set.fromList $ AbiAddress . forceAddr <$> Map.keys vm.env.contracts constants = enhanceConstants slitherInfo <> timeConstants @@ -88,13 +90,12 @@ prepareContract env solFiles specifiedContract seed = do seed (returnTypes contracts) - writeIORef env.testsRef echidnaTests - pure (vm, world, dict) + pure (vm, env, dict) -loadInitialCorpus :: Env -> World -> IO [(FilePath, [Tx])] -loadInitialCorpus env world = do +loadInitialCorpus :: Env -> IO [(FilePath, [Tx])] +loadInitialCorpus env = do -- load transactions from init sequence (if any) - let sigs = Set.fromList $ concatMap NE.toList (Map.elems world.highSignatureMap) + let sigs = Set.fromList $ concatMap NE.toList (Map.elems env.world.highSignatureMap) ethenoCorpus <- case env.cfg.solConf.initialize of Nothing -> pure [] @@ -112,18 +113,19 @@ loadInitialCorpus env world = do pure $ persistedCorpus ++ ethenoCorpus -mkEnv :: EConfig -> BuildOutput -> IO Env -mkEnv cfg buildOutput = do - fetchContractCache <- newIORef mempty - fetchSlotCache <- newIORef mempty +mkEnv :: EConfig -> BuildOutput -> [EchidnaTest] -> World -> IO Env +mkEnv cfg buildOutput tests world = do codehashMap <- newIORef mempty chainId <- maybe (pure Nothing) EVM.Fetch.fetchChainIdFrom cfg.rpcUrl eventQueue <- newChan coverageRef <- newIORef mempty corpusRef <- newIORef mempty - testsRef <- newIORef mempty + testRefs <- traverse newIORef tests + (contractCache, slotCache) <- Onchain.loadRpcCache cfg + fetchContractCache <- newIORef contractCache + fetchSlotCache <- newIORef slotCache -- TODO put in real path let dapp = dappInfo "/" buildOutput pure $ Env { cfg, dapp, codehashMap, fetchContractCache, fetchSlotCache - , chainId, eventQueue, coverageRef, corpusRef, testsRef + , chainId, eventQueue, coverageRef, corpusRef, testRefs, world } diff --git a/lib/Echidna/Campaign.hs b/lib/Echidna/Campaign.hs index 83e522733..615048b71 100644 --- a/lib/Echidna/Campaign.hs +++ b/lib/Echidna/Campaign.hs @@ -15,12 +15,12 @@ import Control.Monad.ST (RealWorld) import Control.Monad.Trans (lift) import Data.Binary.Get (runGetOrFail) import Data.ByteString.Lazy qualified as LBS -import Data.IORef (readIORef, atomicModifyIORef') +import Data.IORef (readIORef, atomicModifyIORef', writeIORef) import Data.Foldable (foldlM) import Data.List qualified as List import Data.Map qualified as Map import Data.Map (Map, (\\)) -import Data.Maybe (isJust, mapMaybe, fromMaybe) +import Data.Maybe (isJust, mapMaybe) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) @@ -29,7 +29,7 @@ import System.Random (mkStdGen) import EVM (cheatCode) import EVM.ABI (getAbi, AbiType(AbiAddressType), AbiValue(AbiAddress)) -import EVM.Solidity (SolcContract) +import EVM.Dapp (DappInfo(..)) import EVM.Types hiding (Env, Frame(state), Gas) import Echidna.ABI @@ -49,7 +49,6 @@ import Echidna.Types.Signature (FunctionName) import Echidna.Types.Test import Echidna.Types.Test qualified as Test import Echidna.Types.Tx (TxCall(..), Tx(..), call) -import Echidna.Types.World (World) import Echidna.Utility (getTimestamp) instance MonadThrow m => MonadThrow (RandT g m) where @@ -87,17 +86,17 @@ runWorker -> StateT WorkerState m () -- ^ Callback to run after each state update (for instrumentation) -> VM Concrete RealWorld -- ^ Initial VM state - -> World -- ^ Initial world state -> GenDict -- ^ Generation dictionary -> Int -- ^ Worker id starting from 0 -> [(FilePath, [Tx])] -- ^ Initial corpus of transactions -> Int -- ^ Test limit for this worker -> Maybe Text -- ^ Specified contract name - -> [SolcContract] -- ^ List of contracts -> m (WorkerStopReason, WorkerState) -runWorker SymbolicWorker callback vm _ dict workerId initialCorpus _ name cs = runSymWorker callback vm dict workerId initialCorpus name cs -runWorker FuzzWorker callback vm world dict workerId initialCorpus testLimit _ _ = runFuzzWorker callback vm world dict workerId initialCorpus testLimit +runWorker SymbolicWorker callback vm dict workerId initialCorpus _ name = + runSymWorker callback vm dict workerId initialCorpus name +runWorker FuzzWorker callback vm dict workerId initialCorpus testLimit _ = + runFuzzWorker callback vm dict workerId initialCorpus testLimit runSymWorker :: (MonadIO m, MonadThrow m, MonadReader Env m) @@ -109,9 +108,8 @@ runSymWorker -> [(FilePath, [Tx])] -- ^ Initial corpus of transactions -> Maybe Text -- ^ Specified contract name - -> [SolcContract] -- ^ List of contracts -> m (WorkerStopReason, WorkerState) -runSymWorker callback vm dict workerId initialCorpus name cs = do +runSymWorker callback vm dict workerId initialCorpus name = do cfg <- asks (.cfg) let nworkers = getNFuzzWorkers cfg.campaignConf -- getNFuzzWorkers, NOT getNWorkers eventQueue <- asks (.eventQueue) @@ -173,7 +171,9 @@ runSymWorker callback vm dict workerId initialCorpus name cs = do symexecTx (tx, vm', txsBase) = do cfg <- asks (.cfg) - (threadId, symTxsChan) <- liftIO $ createSymTx cfg name cs tx vm' + dapp <- asks (.dapp) + let compiledContracts = Map.elems dapp.solcByName + (threadId, symTxsChan) <- liftIO $ createSymTx cfg name compiledContracts tx vm' modify' (\ws -> ws { runningThreads = [threadId] }) lift callback @@ -196,14 +196,13 @@ runFuzzWorker => StateT WorkerState m () -- ^ Callback to run after each state update (for instrumentation) -> VM Concrete RealWorld -- ^ Initial VM state - -> World -- ^ Initial world state -> GenDict -- ^ Generation dictionary -> Int -- ^ Worker id starting from 0 -> [(FilePath, [Tx])] -- ^ Initial corpus of transactions -> Int -- ^ Test limit for this worker -> m (WorkerStopReason, WorkerState) -runFuzzWorker callback vm world dict workerId initialCorpus testLimit = do +runFuzzWorker callback vm dict workerId initialCorpus testLimit = do let effectiveSeed = dict.defSeed + workerId effectiveGenDict = dict { defSeed = effectiveSeed } @@ -226,8 +225,8 @@ runFuzzWorker callback vm world dict workerId initialCorpus testLimit = do where run = do - testsRef <- asks (.testsRef) - tests <- liftIO $ readIORef testsRef + testRefs <- asks (.testRefs) + tests <- liftIO $ traverse readIORef testRefs CampaignConf{stopOnFail, shrinkLimit} <- asks (.cfg.campaignConf) ncalls <- gets (.ncalls) @@ -237,9 +236,13 @@ runFuzzWorker callback vm world dict workerId initialCorpus testLimit = do Failed _ -> True _ -> False - shrinkable test = case test.state of - Large n -> n < shrinkLimit - _ -> False + shrinkable test = + case test.state of + -- we shrink only tests which were solved on this + -- worker, see 'updateOpenTest' + Large n | test.workerId == Just workerId -> + n < shrinkLimit + _ -> False closeOptimizationTest test = case test.testType of OptimizationTest _ _ -> test { Test.state = Large 0 } @@ -248,33 +251,49 @@ runFuzzWorker callback vm world dict workerId initialCorpus testLimit = do if | stopOnFail && any final tests -> lift callback >> pure FastFailed + -- we shrink first before going back to fuzzing + | any shrinkable tests -> + shrink >> lift callback >> run + + -- no shrinking work, fuzz | (null tests || any isOpen tests) && ncalls < testLimit -> - fuzz >> continue + fuzz >> lift callback >> run + -- TODO: This shouldn't really be here, we can infer this state outside + -- of worker. Move this to the UI. | ncalls >= testLimit && any (\t -> isOpen t && isOptimizationTest t) tests -> do - liftIO $ atomicModifyIORef' testsRef $ \sharedTests -> - (closeOptimizationTest <$> sharedTests, ()) - continue - - | any shrinkable tests -> - continue + liftIO $ forM_ testRefs $ \testRef -> + atomicModifyIORef' testRef (\test -> (closeOptimizationTest test, ())) + lift callback >> run + -- no more work to do, means we reached the test limit, exit | otherwise -> lift callback >> pure TestLimitReached - fuzz = randseq vm.env.contracts world >>= fmap fst . callseq vm - - continue = runUpdate (shrinkTest vm) >> lift callback >> run + fuzz = randseq vm.env.contracts >>= fmap fst . callseq vm + + -- To avoid contention we only shrink tests that were falsified by this + -- worker. Tests are marked with a worker in 'updateOpenTest'. + -- + -- TODO: This makes some workers run longer as they work less on their + -- test limit portion during shrinking. We should move to a test limit shared + -- between workers to avoid that. This way other workers will "drain" + -- the work queue. + shrink = updateTests $ \test -> do + if test.workerId == Just workerId then + shrinkTest vm test + else + pure Nothing -- | Generate a new sequences of transactions, either using the corpus or with -- randomly created transactions randseq :: (MonadRandom m, MonadReader Env m, MonadState WorkerState m, MonadIO m) => Map (Expr 'EAddr) Contract - -> World -> m [Tx] -randseq deployedContracts world = do +randseq deployedContracts = do env <- ask + let world = env.world let mutConsts = env.cfg.campaignConf.mutConsts @@ -437,8 +456,7 @@ updateGasInfo ((tx@Tx{call = SolCall (f, _)}, (_, used')):txs) tseq gi = updateGasInfo ((t, _):ts) tseq gi = updateGasInfo ts (t:tseq) gi -- | Given an initial 'VM' state and a way to run transactions, evaluate a list --- of transactions, constantly checking if we've solved any tests or can shrink --- known solves. +-- of transactions, constantly checking if we've solved any tests. evalSeq :: (MonadIO m, MonadThrow m, MonadRandom m, MonadReader Env m, MonadState WorkerState m) => VM Concrete RealWorld -- ^ Initial VM @@ -449,7 +467,7 @@ evalSeq vm0 execFunc = go vm0 [] where go vm executedSoFar toExecute = do -- NOTE: we do reverse here because we build up this list by prepending, -- see the last line of this function. - runUpdate (updateTest vm0 (vm, reverse executedSoFar)) + updateTests (updateOpenTest vm (reverse executedSoFar)) modify' $ \workerState -> workerState { ncalls = workerState.ncalls + 1 } case toExecute of [] -> pure ([], vm) @@ -462,54 +480,65 @@ evalSeq vm0 execFunc = go vm0 [] where (remaining, _vm) <- go vm' (tx:executedSoFar) remainingTxs pure ((tx, result) : remaining, vm') --- | Given a rule for updating a particular test's state, apply it to each test --- in a 'Campaign'. -runUpdate +-- | Update tests based on the return value from the given function. +-- Nothing skips the update. +updateTests :: (MonadIO m, MonadReader Env m, MonadState WorkerState m) => (EchidnaTest -> m (Maybe EchidnaTest)) -> m () -runUpdate f = do - testsRef <- asks (.testsRef) - tests <- liftIO $ readIORef testsRef - updates <- mapM f tests - when (any isJust updates) $ - liftIO $ atomicModifyIORef' testsRef $ \sharedTests -> - (uncurry fromMaybe <$> zip sharedTests updates, ()) - --- | Given an initial 'VM' state and a @('SolTest', 'TestState')@ pair, as well --- as possibly a sequence of transactions and the state after evaluation, see if: --- (0): The test is past its 'testLimit' or 'shrinkLimit' and should be presumed un[solve|shrink]able --- (1): The test is 'Open', and this sequence of transactions solves it --- (2): The test is 'Open', and evaluating it breaks our runtime --- (3): The test is unshrunk, and we can shrink it --- Then update accordingly, keeping track of how many times we've tried to solve or shrink. -updateTest +updateTests f = do + testRefs <- asks (.testRefs) + forM_ testRefs $ \testRef -> do + test <- liftIO $ readIORef testRef + f test >>= \case + Just test' -> liftIO $ writeIORef testRef test' + Nothing -> pure () + +-- | Update an open test after checking if it is falsified by the 'reproducer' +updateOpenTest :: (MonadIO m, MonadThrow m, MonadRandom m, MonadReader Env m, MonadState WorkerState m) - => VM Concrete RealWorld - -> (VM Concrete RealWorld, [Tx]) + => VM Concrete RealWorld -- ^ VM after applying potential reproducer + -> [Tx] -- ^ potential reproducer -> EchidnaTest -> m (Maybe EchidnaTest) -updateTest vmForShrink (vm, xs) test = do +updateOpenTest vm reproducer test = do case test.state of Open -> do (testValue, vm') <- checkETest test vm - let - results = getResultFromVM vm' - test' = updateOpenTest test xs (testValue, vm', results) - case test'.state of - Large _ -> do + let result = getResultFromVM vm' + case testValue of + BoolValue False -> do + workerId <- Just <$> gets (.workerId) + let test' = test { Test.state = Large 0 + , reproducer + , vm = Just vm + , result + , workerId + } pushWorkerEvent (TestFalsified test') - pure (Just test') - _ | test'.value > test.value -> do + pure $ Just test' + + IntValue value' | value' > value -> do + let test' = test { reproducer + , value = IntValue value' + , vm = Just vm + , result + } pushWorkerEvent (TestOptimized test') - pure (Just test') - _ -> pure Nothing - Large _ -> - -- TODO: We shrink already in `step`, but we shrink here too. It makes - -- shrink go faster when some tests are still fuzzed. It's not incorrect - -- but requires passing `vmForShrink` and feels a bit wrong. - shrinkTest vmForShrink test - _ -> pure Nothing + pure $ Just test' + where + value = + case test.value of + IntValue x -> x + -- TODO: fix this with proper types + _ -> error "Invalid type of value for optimization" + + _ -> + -- no luck with fuzzing this time + pure Nothing + _ -> + -- not an open test, skip + pure Nothing pushWorkerEvent :: (MonadReader Env m, MonadState WorkerState m, MonadIO m) diff --git a/lib/Echidna/Onchain.hs b/lib/Echidna/Onchain.hs index f791e5039..d26cfacd1 100644 --- a/lib/Echidna/Onchain.hs +++ b/lib/Echidna/Onchain.hs @@ -10,7 +10,7 @@ import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.UTF8 qualified as UTF8 import Data.Functor ((<&>)) -import Data.IORef (writeIORef, readIORef) +import Data.IORef (readIORef) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (isJust, fromJust, fromMaybe) @@ -100,10 +100,14 @@ toFetchedContractData contract = -- | Try to load the persisted RPC cache. -- TODO: we use the corpus dir for now, think where to place it -loadRpcCache :: Env -> IO () -loadRpcCache Env { cfg, fetchContractCache, fetchSlotCache } = +loadRpcCache + :: EConfig + -> IO ( Map Addr (Maybe Contract) + , Map Addr (Map W256 (Maybe W256)) + ) +loadRpcCache cfg = case cfg.campaignConf.corpusDir of - Nothing -> pure () + Nothing -> pure (mempty, mempty) Just dir -> do let cache_dir = dir "cache" createDirectoryIfMissing True cache_dir @@ -115,10 +119,12 @@ loadRpcCache Env { cfg, fetchContractCache, fetchSlotCache } = parsedSlots :: Maybe (Map Addr (Map W256 (Maybe W256))) <- readFileIfExists (cache_dir "block_" <> show block <> "_fetch_cache_slots.json") <&> (>>= JSON.decodeStrict) - writeIORef fetchContractCache (maybe mempty (Map.map (Just . fromFetchedContractData)) parsedContracts) - writeIORef fetchSlotCache (fromMaybe mempty parsedSlots) + pure + ( maybe mempty (Map.map (Just . fromFetchedContractData)) parsedContracts + , fromMaybe mempty parsedSlots + ) Nothing -> - pure () + pure (mempty, mempty) readFileIfExists :: FilePath -> IO (Maybe BS.ByteString) readFileIfExists path = do diff --git a/lib/Echidna/Output/JSON.hs b/lib/Echidna/Output/JSON.hs index ebacc8183..39bcaa503 100644 --- a/lib/Echidna/Output/JSON.hs +++ b/lib/Echidna/Output/JSON.hs @@ -100,7 +100,7 @@ instance ToJSON Transaction where encodeCampaign :: Env -> [WorkerState] -> IO L.ByteString encodeCampaign env workerStates = do - tests <- readIORef env.testsRef + tests <- traverse readIORef env.testRefs frozenCov <- mapM VU.freeze =<< readIORef env.coverageRef -- TODO: this is ugly, refactor seed to live in Env let worker0 = Prelude.head workerStates diff --git a/lib/Echidna/Solidity.hs b/lib/Echidna/Solidity.hs index 1868ff246..b7e599e16 100644 --- a/lib/Echidna/Solidity.hs +++ b/lib/Echidna/Solidity.hs @@ -30,7 +30,6 @@ import System.Info (os) import EVM (initialContract, currentContract) import EVM.ABI -import EVM.Dapp (DappInfo(..)) import EVM.Solidity import EVM.Types hiding (Env) @@ -42,7 +41,6 @@ import Echidna.Etheno (loadEthenoBatch) import Echidna.Events (extractEvents) import Echidna.Exec (execTx, initialVM) import Echidna.SourceAnalysis.Slither -import Echidna.Symbolic (forceAddr) import Echidna.Test (createTests, isAssertionMode, isPropertyMode, isDapptestMode) import Echidna.Types.Config (EConfig(..), Env(..)) import Echidna.Types.Signature @@ -167,48 +165,12 @@ abiOf pref solcContract = -- filename their code is in, plus a colon. loadSpecified :: Env - -> Maybe Text + -> SolcContract -> [SolcContract] - -> IO (VM Concrete RealWorld, [SolSignature], [Text], SignatureMap) -loadSpecified env name cs = do + -> IO (VM Concrete RealWorld) +loadSpecified env mainContract cs = do let solConf = env.cfg.solConf - -- Pick contract to load - mainContract <- chooseContract cs name - when (isNothing name && length cs > 1 && not solConf.quiet) $ - putStrLn "Multiple contracts found, only analyzing the first" - unless solConf.quiet $ - putStrLn $ "Analyzing contract: " <> T.unpack mainContract.contractName - - let - -- generate the complete abi mapping - abi = Map.elems mainContract.abiMap <&> \method -> (method.name, snd <$> method.inputs) - (tests, funs) = partition (isPrefixOf solConf.prefix . fst) abi - - -- Filter ABI according to the config options - fabiOfc = if isDapptestMode solConf.testMode - then NE.toList $ filterMethodsWithArgs (abiOf solConf.prefix mainContract) - else filterMethods mainContract.contractName solConf.methodFilter $ - abiOf solConf.prefix mainContract - -- Filter again for dapptest tests or assertions checking if enabled - neFuns = filterMethods mainContract.contractName solConf.methodFilter (fallback NE.:| funs) - -- Construct ABI mapping for World - abiMapping = - if solConf.allContracts then - Map.fromList $ mapMaybe (\contract -> - let filtered = filterMethods contract.contractName - solConf.methodFilter - (abiOf solConf.prefix contract) - in (contract.runtimeCodehash,) <$> NE.nonEmpty filtered) - cs - else - case NE.nonEmpty fabiOfc of - Just ne -> Map.singleton mainContract.runtimeCodehash ne - Nothing -> mempty - - when (Map.null abiMapping) $ - throwM $ InvalidMethodFilters solConf.methodFilter - -- Set up initial VM, either with chosen contract or Etheno initialization file -- need to use snd to add to ABI dict initVM <- stToIO $ initialVM solConf.allowFFI @@ -225,20 +187,6 @@ loadSpecified env name cs = do -- Select libraries ls <- mapM (chooseContract cs . Just . T.pack) solConf.solcLibs - -- Make sure everything is ready to use, then ship it - when (null abi) $ - throwM NoFuncs - when (null tests && isPropertyMode solConf.testMode) $ - throwM NoTests - when (null abiMapping && isDapptestMode solConf.testMode) $ - throwM NoTests - when (mainContract.creationCode == mempty) $ - throwM (NoBytecode mainContract.contractName) - - case find (not . null . snd) tests of - Just (t, _) -> throwM $ TestArgsFound t - Nothing -> pure () - flip runReaderT env $ do -- library deployment vm0 <- deployContracts (zip [addrLibrary ..] ls) solConf.deployer blank @@ -262,24 +210,104 @@ loadSpecified env name cs = do when (isNothing $ currentContract vm3) $ throwM $ DeploymentFailed solConf.contractAddr $ T.unlines $ extractEvents True env.dapp vm3 - -- Run - let transaction = execTx vm3 $ uncurry basicTx - setUpFunction - solConf.deployer - solConf.contractAddr - unlimitedGasPerBlock - (0, 0) + -- Run setUp function + let + abi = Map.elems mainContract.abiMap <&> \method -> (method.name, snd <$> method.inputs) + transaction = execTx vm3 $ uncurry basicTx + setUpFunction + solConf.deployer + solConf.contractAddr + unlimitedGasPerBlock + (0, 0) vm4 <- if isDapptestMode solConf.testMode && setUpFunction `elem` abi then snd <$> transaction else pure vm3 case vm4.result of Just (VMFailure _) -> throwM SetUpCallFailed - _ -> pure (vm4, neFuns, fst <$> tests, abiMapping) + _ -> pure vm4 where setUpFunction = ("setUp", []) + +selectMainContract + :: SolConf + -> Maybe ContractName + -> [SolcContract] + -> IO SolcContract +selectMainContract solConf name cs = do + -- Pick contract to load + mainContract <- chooseContract cs name + when (isNothing name && length cs > 1 && not solConf.quiet) $ + putStrLn "Multiple contracts found, only analyzing the first" + unless solConf.quiet $ + putStrLn $ "Analyzing contract: " <> T.unpack mainContract.contractName + when (mainContract.creationCode == mempty) $ + throwM (NoBytecode mainContract.contractName) + pure mainContract + +mkSignatureMap + :: SolConf + -> SolcContract + -> [SolcContract] + -> IO SignatureMap +mkSignatureMap solConf mainContract contracts = do + let + -- Filter ABI according to the config options + fabiOfc = if isDapptestMode solConf.testMode + then NE.toList $ filterMethodsWithArgs (abiOf solConf.prefix mainContract) + else filterMethods mainContract.contractName solConf.methodFilter $ + abiOf solConf.prefix mainContract + -- Construct ABI mapping for World + abiMapping = + if solConf.allContracts then + Map.fromList $ mapMaybe (\contract -> + let filtered = filterMethods contract.contractName + solConf.methodFilter + (abiOf solConf.prefix contract) + in (contract.runtimeCodehash,) <$> NE.nonEmpty filtered) + contracts + else + case NE.nonEmpty fabiOfc of + Just ne -> Map.singleton mainContract.runtimeCodehash ne + Nothing -> mempty + when (null abiMapping && isDapptestMode solConf.testMode) $ + throwM NoTests + when (Map.null abiMapping) $ + throwM $ InvalidMethodFilters solConf.methodFilter + pure abiMapping + +mkTests + :: SolConf + -> SolcContract + -> IO [EchidnaTest] +mkTests solConf mainContract = do + let + -- generate the complete abi mapping + abi = Map.elems mainContract.abiMap <&> \method -> (method.name, snd <$> method.inputs) + (tests, funs) = partition (isPrefixOf solConf.prefix . fst) abi + -- Filter again for dapptest tests or assertions checking if enabled + neFuns = filterMethods mainContract.contractName + solConf.methodFilter + (fallback NE.:| funs) + testNames = fst <$> tests + + when (null abi) $ + throwM NoFuncs + when (null tests && isPropertyMode solConf.testMode) $ + throwM NoTests + + case find (not . null . snd) tests of + Just (t, _) -> throwM $ TestArgsFound t + Nothing -> pure () + + pure $ createTests solConf.testMode + solConf.testDestruction + testNames + solConf.contractAddr + neFuns + -- | Given a list of contracts and a requested contract name, pick a contract. -- See 'loadSpecified' for more information. chooseContract :: (MonadThrow m) => [SolcContract] -> Maybe Text -> m SolcContract @@ -369,25 +397,6 @@ prepareHashMaps cs as m = filterHashMap f xs = Map.mapMaybe (NE.nonEmpty . NE.filter (\s -> f $ (hashSig . encodeSig $ s) `elem` xs)) --- | Given a file and an optional contract name, compile the file as solidity, then, if a name is --- given, try to fine the specified contract (assuming it is in the file provided), otherwise, find --- the first contract in the file. Take said contract and return an initial VM state with it loaded, --- its ABI (as 'SolSignature's), and the names of its Echidna tests. NOTE: unlike 'loadSpecified', --- contract names passed here don't need the file they occur in specified. -loadSolTests - :: Env - -> Maybe Text - -> IO (VM Concrete RealWorld, World, [EchidnaTest]) -loadSolTests env name = do - let solConf = env.cfg.solConf - let contracts = Map.elems env.dapp.solcByName - (vm, funs, testNames, _signatureMap) <- loadSpecified env name contracts - let - eventMap = Map.unions $ map (.eventMap) contracts - world = World solConf.sender mempty Nothing [] eventMap - echidnaTests = createTests solConf.testMode True testNames (forceAddr vm.state.contract) funs - pure (vm, world, echidnaTests) - mkLargeAbiInt :: Int -> AbiValue mkLargeAbiInt i = AbiInt i $ 2 ^ (i - 1) - 1 diff --git a/lib/Echidna/Test.hs b/lib/Echidna/Test.hs index 05837fe41..e11886f3d 100644 --- a/lib/Echidna/Test.hs +++ b/lib/Echidna/Test.hs @@ -24,7 +24,6 @@ import Echidna.Symbolic (forceBuf) import Echidna.Types.Config import Echidna.Types.Signature (SolSignature) import Echidna.Types.Test -import Echidna.Types.Test qualified as Test import Echidna.Types.Tx (Tx, TxConf(..), basicTx, TxResult(..), getResult) --- | Possible responses to a call to an Echidna test: @true@, @false@, @REVERT@, and ???. @@ -47,7 +46,7 @@ getResultFromVM vm = Nothing -> error "getResultFromVM failed" createTest :: TestType -> EchidnaTest -createTest m = EchidnaTest Open m v [] Stop Nothing +createTest m = EchidnaTest Open m v [] Stop Nothing Nothing where v = case m of PropertyTest _ _ -> BoolValue True OptimizationTest _ _ -> IntValue minBound @@ -111,6 +110,7 @@ createTests m td ts r ss = case m of sdt = createTest (CallTest "Target contract is not self-destructed" $ checkSelfDestructedTarget r) sdat = createTest (CallTest "No contract can be self-destructed" checkAnySelfDestructed) + {- updateOpenTest :: EchidnaTest -> [Tx] @@ -133,6 +133,7 @@ updateOpenTest test txs (IntValue v', vm, r) = IntValue x -> x _ -> error "Invalid type of value for optimization" updateOpenTest _ _ _ = error "Invalid type of test" +-} -- | Given a 'SolTest', evaluate it and see if it currently passes. checkETest diff --git a/lib/Echidna/Types/Config.hs b/lib/Echidna/Types/Config.hs index 64bae8b79..62f4e7513 100644 --- a/lib/Echidna/Types/Config.hs +++ b/lib/Echidna/Types/Config.hs @@ -19,6 +19,7 @@ import Echidna.Types.Coverage (CoverageMap) import Echidna.Types.Solidity (SolConf) import Echidna.Types.Test (TestConf, EchidnaTest) import Echidna.Types.Tx (TxConf) +import Echidna.Types.World (World) data OperationMode = Interactive | NonInteractive OutputFormat deriving (Show, Eq) data OutputFormat = Text | JSON | None deriving (Show, Eq) @@ -68,7 +69,7 @@ data Env = Env -- minimal. , eventQueue :: Chan (LocalTime, CampaignEvent) - , testsRef :: IORef [EchidnaTest] + , testRefs :: [IORef EchidnaTest] , coverageRef :: IORef CoverageMap , corpusRef :: IORef Corpus @@ -76,4 +77,5 @@ data Env = Env , fetchContractCache :: IORef (Map Addr (Maybe Contract)) , fetchSlotCache :: IORef (Map Addr (Map W256 (Maybe W256))) , chainId :: Maybe W256 + , world :: World } diff --git a/lib/Echidna/Types/Test.hs b/lib/Echidna/Types/Test.hs index 2221aa39e..7f6e00925 100644 --- a/lib/Echidna/Types/Test.hs +++ b/lib/Echidna/Types/Test.hs @@ -102,6 +102,8 @@ data EchidnaTest = EchidnaTest , reproducer :: [Tx] , result :: TxResult , vm :: Maybe (VM Concrete RealWorld) + -- | Worker which falsified the test will also shrink it. + , workerId :: Maybe Int } deriving (Show) instance ToJSON EchidnaTest where diff --git a/lib/Echidna/UI.hs b/lib/Echidna/UI.hs index 000d87527..b28d2d5ac 100644 --- a/lib/Echidna/UI.hs +++ b/lib/Echidna/UI.hs @@ -61,13 +61,11 @@ data UIEvent = ui :: (MonadCatch m, MonadReader Env m, MonadUnliftIO m) => VM Concrete RealWorld -- ^ Initial VM state - -> World -- ^ Initial world state -> GenDict -> [(FilePath, [Tx])] -> Maybe Text - -> [SolcContract] -> m [WorkerState] -ui vm world dict initialCorpus cliSelectedContract cs = do +ui vm dict initialCorpus cliSelectedContract = do env <- ask conf <- asks (.cfg) terminalPresent <- liftIO isTerminal @@ -106,7 +104,7 @@ ui vm world dict initialCorpus cliSelectedContract cs = do threadDelay 200_000 -- 200 ms now <- getTimestamp - tests <- readIORef env.testsRef + tests <- traverse readIORef env.testRefs states <- workerStates workers writeBChan uiChannel (CampaignUpdated now tests states) @@ -124,7 +122,7 @@ ui vm world dict initialCorpus cliSelectedContract cs = do app <- customMain initialVty buildVty (Just uiChannel) <$> monitor liftIO $ do - tests <- readIORef env.testsRef + tests <- traverse readIORef env.testRefs now <- getTimestamp void $ app UIState { campaigns = [initialWorkerState] -- ugly, fix me @@ -229,7 +227,7 @@ ui vm world dict initialCorpus cliSelectedContract cs = do corpus = if workerType == SymbolicWorker then initialCorpus else corpusChunk maybeResult <- timeout timeoutUsecs $ runWorker workerType (get >>= writeIORef stateRef) - vm world dict workerId corpus testLimit cliSelectedContract cs + vm dict workerId corpus testLimit cliSelectedContract pure $ case maybeResult of Just (stopReason, _finalState) -> stopReason Nothing -> TimeLimitReached @@ -355,7 +353,7 @@ statusLine -> [WorkerState] -> IO String statusLine env states = do - tests <- readIORef env.testsRef + tests <- traverse readIORef env.testRefs points <- scoveragePoints =<< readIORef env.coverageRef corpus <- readIORef env.corpusRef let totalCalls = sum ((.ncalls) <$> states) diff --git a/lib/Echidna/UI/Report.hs b/lib/Echidna/UI/Report.hs index fa6d47b3e..23ee7bb2f 100644 --- a/lib/Echidna/UI/Report.hs +++ b/lib/Echidna/UI/Report.hs @@ -45,7 +45,7 @@ ppCampaignEventLog vm ev = (ppCampaignEvent ev <>) <$> ppTxIfHas where ppCampaign :: (MonadIO m, MonadReader Env m) => VM Concrete RealWorld -> [WorkerState] -> m String ppCampaign vm workerStates = do - tests <- liftIO . readIORef =<< asks (.testsRef) + tests <- liftIO . traverse readIORef =<< asks (.testRefs) testsPrinted <- ppTests tests gasInfoPrinted <- ppGasInfo vm workerStates coveragePrinted <- ppCoverage diff --git a/lib/Echidna/UI/Widgets.hs b/lib/Echidna/UI/Widgets.hs index 6426ef848..87739af36 100644 --- a/lib/Echidna/UI/Widgets.hs +++ b/lib/Echidna/UI/Widgets.hs @@ -31,7 +31,7 @@ import Echidna.ABI import Echidna.Types.Campaign import Echidna.Types.Config import Echidna.Types.Test -import Echidna.Types.Tx (Tx(..), TxResult(..)) +import Echidna.Types.Tx (Tx(..)) import Echidna.UI.Report import Echidna.Utility (timePrefix) @@ -304,13 +304,13 @@ tsWidget => TestState -> EchidnaTest -> m (Widget Name, Widget Name) -tsWidget (Failed e) _ = pure (str "could not evaluate", str $ show e) -tsWidget Solved t = failWidget Nothing t.reproducer (fromJust t.vm) t.value t.result -tsWidget Passed _ = pure (success $ str "PASSED!", emptyWidget) -tsWidget Open _ = pure (success $ str "passing", emptyWidget) -tsWidget (Large n) t = do +tsWidget (Failed e) _ = pure (str "could not evaluate", str $ show e) +tsWidget Solved test = failWidget Nothing test +tsWidget Passed _ = pure (success $ str "PASSED!", emptyWidget) +tsWidget Open _ = pure (success $ str "passing", emptyWidget) +tsWidget (Large n) test = do m <- asks (.cfg.campaignConf.shrinkLimit) - failWidget (if n < m then Just (n,m) else Nothing) t.reproducer (fromJust t.vm) t.value t.result + failWidget (if n < m then Just (n,m) else Nothing) test titleWidget :: Widget n titleWidget = str "Call sequence" <+> str ":" @@ -329,17 +329,18 @@ tracesWidget vm = do failWidget :: MonadReader Env m => Maybe (Int, Int) - -> [Tx] - -> VM Concrete RealWorld - -> TestValue - -> TxResult + -> EchidnaTest -> m (Widget Name, Widget Name) -failWidget _ [] _ _ _= pure (failureBadge, str "*no transactions made*") -failWidget b xs vm _ r = do - s <- seqWidget vm xs +failWidget _ test | null test.reproducer = + pure (failureBadge, str "*no transactions made*") +failWidget b test = do + -- TODO: we know this is set for failed tests, ideally we should improve this + -- with better types in EchidnaTest + let vm = fromJust test.vm + s <- seqWidget vm test.reproducer traces <- tracesWidget vm pure - ( failureBadge <+> str (" with " ++ show r) + ( failureBadge <+> str (" with " ++ show test.result) , status <=> titleWidget <=> s <=> str " " <=> traces ) where @@ -347,7 +348,9 @@ failWidget b xs vm _ r = do Nothing -> emptyWidget Just (n,m) -> str "Current action: " <+> - withAttr (attrName "working") (str ("shrinking " ++ progress n m)) + withAttr (attrName "working") + (str ("shrinking " ++ progress n m ++ showWorker)) + showWorker = maybe "" (\i -> " (worker " <> show i <> ")") test.workerId optWidget :: MonadReader Env m diff --git a/src/Main.hs b/src/Main.hs index d64f4023a..9e1d68d49 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -29,7 +29,7 @@ import System.IO (hPutStrLn, stderr) import System.IO.CodePage (withCP65001) import EVM.Dapp (DappInfo(..)) -import EVM.Solidity (BuildOutput(..), Contracts(..)) +import EVM.Solidity (BuildOutput(..)) import EVM.Types (Addr) import Echidna @@ -59,20 +59,16 @@ main = withUtf8 $ withCP65001 $ do forM_ ks $ hPutStrLn stderr . ("Warning: unused option: " ++) . Aeson.Key.toString buildOutput <- compileContracts cfg.solConf cliFilePath - env <- mkEnv cfg buildOutput - - Onchain.loadRpcCache env -- take the seed from config, otherwise generate a new one seed <- maybe (getRandomR (0, maxBound)) pure cfg.campaignConf.seed - (vm, world, dict) <- prepareContract env cliFilePath cliSelectedContract seed + (vm, env, dict) <- prepareContract cfg cliFilePath buildOutput cliSelectedContract seed - initialCorpus <- loadInitialCorpus env world - let (Contracts contractMap) = buildOutput.contracts + initialCorpus <- loadInitialCorpus env -- start ui and run tests - _campaign <- runReaderT (ui vm world dict initialCorpus cliSelectedContract (Map.elems contractMap)) env + _campaign <- runReaderT (ui vm dict initialCorpus cliSelectedContract) env - tests <- readIORef env.testsRef + tests <- traverse readIORef env.testRefs Onchain.saveRpcCache env diff --git a/src/test/Common.hs b/src/test/Common.hs index ae658a76a..884e11384 100644 --- a/src/test/Common.hs +++ b/src/test/Common.hs @@ -18,6 +18,7 @@ module Common , gasInRange , countCorpus , overrideQuiet + , loadSolTests ) where import Test.Tasty (TestTree) @@ -26,6 +27,7 @@ import Test.Tasty.HUnit (testCase, assertBool) import Control.Monad (forM_) import Control.Monad.Reader (runReaderT) import Control.Monad.Random (getRandomR) +import Control.Monad.ST (RealWorld) import Data.DoubleWord (Int256) import Data.Function ((&)) import Data.IORef @@ -40,7 +42,7 @@ import System.Process (readProcess) import Echidna (mkEnv, prepareContract) import Echidna.Config (parseConfig, defaultConfig) import Echidna.Campaign (runWorker) -import Echidna.Solidity (loadSolTests, compileContracts) +import Echidna.Solidity (selectMainContract, mkTests, loadSpecified, compileContracts) import Echidna.Test (checkETest) import Echidna.Types (Gas) import Echidna.Types.Config (Env(..), EConfig(..), EConfigWithUsage(..)) @@ -49,8 +51,10 @@ import Echidna.Types.Signature (ContractName) import Echidna.Types.Solidity (SolConf(..)) import Echidna.Types.Test import Echidna.Types.Tx (Tx(..), TxCall(..), call) +import Echidna.Types.World (World(..)) -import EVM.Solidity (Contracts(..), BuildOutput(..)) +import EVM.Solidity (Contracts(..), BuildOutput(..), SolcContract(..)) +import EVM.Types hiding (Env, Gas) testConfig :: EConfig testConfig = defaultConfig & overrideQuiet @@ -89,14 +93,11 @@ runContract :: FilePath -> Maybe ContractName -> EConfig -> WorkerType -> IO (En runContract f selectedContract cfg workerType = do seed <- maybe (getRandomR (0, maxBound)) pure cfg.campaignConf.seed buildOutput <- compileContracts cfg.solConf (f :| []) - env <- mkEnv cfg buildOutput - (vm, world, dict) <- prepareContract env (f :| []) selectedContract seed - - let (Contracts contractMap) = buildOutput.contracts + (vm, env, dict) <- prepareContract cfg (f :| []) buildOutput selectedContract seed (_stopReason, finalState) <- flip runReaderT env $ - runWorker workerType (pure ()) vm world dict 0 [] cfg.campaignConf.testLimit selectedContract (Map.elems contractMap) + runWorker workerType (pure ()) vm dict 0 [] cfg.campaignConf.testLimit selectedContract -- TODO: consider snapshotting the state so checking function don't need to -- be IO @@ -138,12 +139,33 @@ testContract' fp n v configPath s workerType expectations = testCase fp $ withSo forM_ expectations $ \(message, assertion) -> do assertion result >>= assertBool message +-- | Given a file and an optional contract name, compile the file as solidity, then, if a name is +-- given, try to fine the specified contract (assuming it is in the file provided), otherwise, find +-- the first contract in the file. Take said contract and return an initial VM state with it loaded, +-- its ABI (as 'SolSignature's), and the names of its Echidna tests. NOTE: unlike 'loadSpecified', +-- contract names passed here don't need the file they occur in specified. +loadSolTests + :: EConfig + -> BuildOutput + -> Maybe Text + -> IO (VM Concrete RealWorld, Env, [EchidnaTest]) +loadSolTests cfg buildOutput name = do + let solConf = cfg.solConf + (Contracts contractMap) = buildOutput.contracts + contracts = Map.elems contractMap + eventMap = Map.unions $ map (.eventMap) contracts + world = World solConf.sender mempty Nothing [] eventMap + mainContract <- selectMainContract solConf name contracts + echidnaTests <- mkTests solConf mainContract + env <- mkEnv cfg buildOutput echidnaTests world + vm <- loadSpecified env mainContract contracts + pure (vm, env, echidnaTests) + checkConstructorConditions :: FilePath -> String -> TestTree checkConstructorConditions fp as = testCase fp $ do let cfg = testConfig buildOutput <- compileContracts cfg.solConf (pure fp) - env <- mkEnv cfg buildOutput - (v, _, t) <- loadSolTests env Nothing + (v, env, t) <- loadSolTests cfg buildOutput Nothing r <- flip runReaderT env $ mapM (`checkETest` v) t mapM_ (\(x,_) -> assertBool as (forceBool x)) r where forceBool (BoolValue b) = b @@ -165,7 +187,7 @@ getResult n tests = optnFor :: Text -> (Env, WorkerState) -> IO (Maybe TestValue) optnFor n (env, _) = do - tests <- readIORef env.testsRef + tests <- traverse readIORef env.testRefs pure $ case getResult n tests of Just t -> Just t.value _ -> Nothing @@ -180,7 +202,7 @@ optimized n v final = do solnFor :: Text -> (Env, WorkerState) -> IO (Maybe [Tx]) solnFor n (env, _) = do - tests <- readIORef env.testsRef + tests <- traverse readIORef env.testRefs pure $ case getResult n tests of Just t -> if null t.reproducer then Nothing else Just t.reproducer _ -> Nothing @@ -190,7 +212,7 @@ solved t f = isJust <$> solnFor t f passed :: Text -> (Env, WorkerState) -> IO Bool passed n (env, _) = do - tests <- readIORef env.testsRef + tests <- traverse readIORef env.testRefs pure $ case getResult n tests of Just t | isPassed t -> True Just t | isOpen t -> True diff --git a/src/test/Tests/Compile.hs b/src/test/Tests/Compile.hs index c4048e504..0b30583ec 100644 --- a/src/test/Tests/Compile.hs +++ b/src/test/Tests/Compile.hs @@ -3,13 +3,12 @@ module Tests.Compile (compilationTests) where import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, assertBool) -import Common (testConfig) +import Common (testConfig, loadSolTests) import Control.Monad (void) import Control.Monad.Catch (catch) import Data.Text (Text) -import Echidna (mkEnv) -import Echidna.Solidity (compileContracts, loadSolTests) +import Echidna.Solidity (compileContracts) import Echidna.Types.Solidity (SolException(..)) import Echidna.Types.Config (EConfig(..)) @@ -42,5 +41,4 @@ loadFails fp c e p = testCase fp . catch tryLoad $ assertBool e . p where tryLoad = do let cfg = testConfig buildOutput <- compileContracts cfg.solConf (pure fp) - env <- mkEnv cfg buildOutput - void $ loadSolTests env c + void $ loadSolTests cfg buildOutput c diff --git a/src/test/Tests/Seed.hs b/src/test/Tests/Seed.hs index 78897b921..7793af1c3 100644 --- a/src/test/Tests/Seed.hs +++ b/src/test/Tests/Seed.hs @@ -40,5 +40,5 @@ seedTests = & overrideQuiet gen s = do (env, _) <- runContract "basic/flags.sol" Nothing (cfg s) FuzzWorker - readIORef env.testsRef + traverse readIORef env.testRefs same s t = (\x y -> ((.reproducer) <$> x) == ((.reproducer) <$> y)) <$> gen s <*> gen t