Merge remote-tracking branch 'origin/master' into dev-ghc-9.6

.github/scripts/install-z3.sh

@@ -0,0 +1,10 @@
+#!/bin/bash
+set -eux -o pipefail
+
+if [ "$HOST_OS" = "Linux" ]; then
+  sudo apt-get update
+  sudo apt-get install -y z3
+fi
+if [ "$HOST_OS" = "Windows" ]; then
+  choco install z3
+fi

.github/workflows/ci.yml

@@ -216,6 +216,7 @@ jobs:
         run: |
           .github/scripts/install-solc.sh
           .github/scripts/install-crytic-compile.sh
+          .github/scripts/install-z3.sh
         env:
           HOST_OS: ${{ runner.os }}
           SOLC_VER: ${{ matrix.solc }}

lib/Echidna/Campaign.hs

@@ -5,7 +5,7 @@ module Echidna.Campaign where
 
 import Control.Concurrent
 import Control.DeepSeq (force)
-import Control.Monad (replicateM, when, void, forM_)
+import Control.Monad (replicateM, when, unless, void, forM_)
 import Control.Monad.Catch (MonadThrow(..))
 import Control.Monad.Random.Strict (MonadRandom, RandT, evalRandT)
 import Control.Monad.Reader (MonadReader, asks, liftIO, ask)
@@ -16,6 +16,7 @@ import Control.Monad.Trans (lift)
 import Data.Binary.Get (runGetOrFail)
 import Data.ByteString.Lazy qualified as LBS
 import Data.IORef (readIORef, atomicModifyIORef')
+import Data.Foldable (foldlM)
 import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Map (Map, (\\))
@@ -28,13 +29,15 @@ import System.Random (mkStdGen)
 
 import EVM (cheatCode)
 import EVM.ABI (getAbi, AbiType(AbiAddressType), AbiValue(AbiAddress))
+import EVM.Solidity (SolcContract)
 import EVM.Types hiding (Env, Frame(state), Gas)
 
 import Echidna.ABI
 import Echidna.Exec
 import Echidna.Mutator.Corpus
 import Echidna.Shrink (shrinkTest)
 import Echidna.Symbolic (forceAddr)
+import Echidna.SymExec (createSymTx)
 import Echidna.Test
 import Echidna.Transaction
 import Echidna.Types (Gas)
@@ -78,10 +81,116 @@ replayCorpus vm txSeqs =
       Just faultyTx ->
         pushWorkerEvent (TxSequenceReplayFailed file faultyTx)
 
+runWorker
+  :: (MonadIO m, MonadThrow m, MonadReader Env m)
+  => WorkerType
+  -> 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
+
+runSymWorker
+  :: (MonadIO m, MonadThrow m, MonadReader Env m)
+  => StateT WorkerState m ()
+  -- ^ Callback to run after each state update (for instrumentation)
+  -> VM Concrete RealWorld -- ^ Initial VM state
+  -> GenDict -- ^ Generation dictionary
+  -> Int     -- ^ Worker id starting from 0
+  -> [(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
+  cfg <- asks (.cfg)
+  let nworkers = getNFuzzWorkers cfg.campaignConf -- getNFuzzWorkers, NOT getNWorkers
+  eventQueue <- asks (.eventQueue)
+  chan <- liftIO $ dupChan eventQueue
+
+  flip runStateT initialState $
+    flip evalRandT (mkStdGen effectiveSeed) $ do -- unused but needed for callseq
+      lift callback
+      void $ replayCorpus vm initialCorpus
+      symexecTxs []
+      mapM_ (symexecTxs . snd) initialCorpus
+      listenerLoop listenerFunc chan nworkers
+      pure SymbolicDone
+
+  where
+
+  effectiveSeed = dict.defSeed + workerId
+  effectiveGenDict = dict { defSeed = effectiveSeed }
+  initialState =
+    WorkerState { workerId
+                , gasInfo = mempty
+                , genDict = effectiveGenDict
+                , newCoverage = False
+                , ncallseqs = 0
+                , ncalls = 0
+                , runningThreads = []
+                }
+
+  -- We could pattern match on workerType here to ignore WorkerEvents from SymbolicWorkers,
+  -- but it may be useful to symexec on top of symexec results to produce multi-transaction
+  -- chains where each transaction results in new coverage.
+  listenerFunc (_, WorkerEvent _ _ (NewCoverage {transactions})) = do
+    void $ callseq vm transactions
+    symexecTxs transactions
+  listenerFunc _ = pure ()
+
+  symexecTxs txs = mapM_ symexecTx =<< txsToTxAndVms txs
+
+  -- | Turn a list of transactions into inputs for symexecTx:
+  -- (maybe txn to concolic execute on, vm to symexec on, list of txns we're on top of)
+  txsToTxAndVms txs = do
+    isConc <- asks (.cfg.campaignConf.symExecConcolic)
+    if isConc
+      then txsToTxAndVmsConc txs vm []
+      else txsToTxAndVmsSym txs
+
+  txsToTxAndVmsConc [] _ _ = pure []
+  txsToTxAndVmsConc (h:t) vm' txsBase = do
+    (_, vm'') <- execTx vm' h
+    rest <- txsToTxAndVmsConc t vm'' (txsBase <> [h])
+    pure $ case h of
+             (Tx { call = SolCall _ }) -> (Just h,vm',txsBase):rest
+             _ -> rest
+
+  txsToTxAndVmsSym txs = do
+    vm' <- foldlM (\vm' tx -> snd <$> execTx vm' tx) vm txs
+    pure [(Nothing,vm',txs)]
+
+  symexecTx (tx, vm', txsBase) = do
+    cfg <- asks (.cfg)
+    (threadId, symTxsChan) <- liftIO $ createSymTx cfg name cs tx vm'
+
+    modify' (\ws -> ws { runningThreads = [threadId] })
+    lift callback
+
+    symTxs <- liftIO $ takeMVar symTxsChan
+
+    modify' (\ws -> ws { runningThreads = [] })
+    lift callback
+
+    -- We can't do callseq vm' [symTx] because callseq might post the full call sequence as an event
+    newCoverage <- or <$> mapM (\symTx -> snd <$> callseq vm (txsBase <> [symTx])) symTxs
+
+    unless newCoverage (pushWorkerEvent SymNoNewCoverage)
+
 -- | Run a fuzzing campaign given an initial universe state, some tests, and an
 -- optional dictionary to generate calls with. Return the 'Campaign' state once
 -- we can't solve or shrink anything.
-runWorker
+runFuzzWorker
   :: (MonadIO m, MonadThrow m, MonadReader Env m)
   => StateT WorkerState m ()
   -- ^ Callback to run after each state update (for instrumentation)
@@ -93,7 +202,7 @@ runWorker
   -- ^ Initial corpus of transactions
   -> Int     -- ^ Test limit for this worker
   -> m (WorkerStopReason, WorkerState)
-runWorker callback vm world dict workerId initialCorpus testLimit = do
+runFuzzWorker callback vm world dict workerId initialCorpus testLimit = do
   let
     effectiveSeed = dict.defSeed + workerId
     effectiveGenDict = dict { defSeed = effectiveSeed }
@@ -104,6 +213,7 @@ runWorker callback vm world dict workerId initialCorpus testLimit = do
                   , newCoverage = False
                   , ncallseqs = 0
                   , ncalls = 0
+                  , runningThreads = []
                   }
 
   flip runStateT initialState $ do
@@ -150,7 +260,7 @@ runWorker callback vm world dict workerId initialCorpus testLimit = do
        | otherwise ->
          lift callback >> pure TestLimitReached
 
-  fuzz = randseq vm.env.contracts world >>= callseq vm
+  fuzz = randseq vm.env.contracts world >>= fmap fst . callseq vm
 
   continue = runUpdate (shrinkTest vm) >> lift callback >> run
 
@@ -183,13 +293,16 @@ randseq deployedContracts world = do
     then pure randTxs -- Use the generated random transactions
     else mut seqLen corpus randTxs -- Apply the mutator
 
+-- TODO callseq ideally shouldn't need to be MonadRandom
+
 -- | Runs a transaction sequence and checks if any test got falsified or can be
 -- minimized. Stores any useful data in the campaign state if coverage increased.
+-- Returns resulting VM, as well as whether any new coverage was found.
 callseq
   :: (MonadIO m, MonadThrow m, MonadRandom m, MonadReader Env m, MonadState WorkerState m)
   => VM Concrete RealWorld
   -> [Tx]
-  -> m (VM Concrete RealWorld)
+  -> m (VM Concrete RealWorld, Bool)
 callseq vm txSeq = do
   env <- ask
   -- First, we figure out whether we need to execute with or without coverage
@@ -254,7 +367,7 @@ callseq vm txSeq = do
       , ncallseqs = workerState.ncallseqs + 1
       }
 
-  pure vm'
+  pure (vm', newCoverage)
 
   where
   -- Given a list of transactions and a return typing rule, checks whether we
@@ -402,7 +515,8 @@ pushWorkerEvent
 pushWorkerEvent event = do
   workerId <- gets (.workerId)
   env <- ask
-  liftIO $ pushCampaignEvent env (WorkerEvent workerId event)
+  let workerType = workerIDToType env.cfg.campaignConf workerId
+  liftIO $ pushCampaignEvent env (WorkerEvent workerId workerType event)
 
 pushCampaignEvent :: Env -> CampaignEvent -> IO ()
 pushCampaignEvent env event = do
@@ -424,17 +538,28 @@ spawnListener
   -> m (MVar ())
 spawnListener handler = do
   cfg <- asks (.cfg)
-  let nworkers = fromMaybe 1 cfg.campaignConf.workers
+  let nworkers = getNWorkers cfg.campaignConf
   eventQueue <- asks (.eventQueue)
   chan <- liftIO $ dupChan eventQueue
   stopVar <- liftIO newEmptyMVar
-  liftIO $ void $ forkFinally (loop chan nworkers) (const $ putMVar stopVar ())
+  liftIO $ void $ forkFinally (listenerLoop handler chan nworkers) (const $ putMVar stopVar ())
   pure stopVar
-  where
-  loop chan !workersAlive =
-    when (workersAlive > 0) $ do
-      event <- readChan chan
-      handler event
-      case event of
-        (_, WorkerEvent _ (WorkerStopped _)) -> loop chan (workersAlive - 1)
-        _                                    -> loop chan workersAlive
+
+-- | Repeatedly run 'handler' on events from 'chan'.
+-- Stops once 'workersAlive' workers stop.
+listenerLoop
+  :: (MonadIO m)
+  => ((LocalTime, CampaignEvent) -> m ())
+  -- ^ a function that handles the events
+  -> Chan (LocalTime, CampaignEvent)
+  -- ^ event channel
+  -> Int
+  -- ^ number of workers which have to stop before loop exits
+  -> m ()
+listenerLoop handler chan !workersAlive =
+  when (workersAlive > 0) $ do
+    event <- liftIO $ readChan chan
+    handler event
+    case event of
+      (_, WorkerEvent _ _ (WorkerStopped _)) -> listenerLoop handler chan (workersAlive - 1)
+      _                                      -> listenerLoop handler chan workersAlive

lib/Echidna/Config.hs

@@ -97,6 +97,12 @@ instance FromJSON EConfigWithUsage where
         <*> v ..:? "coverageFormats" ..!= [Txt,Html,Lcov]
         <*> v ..:? "workers"
         <*> v ..:? "server"
+        <*> v ..:? "symExec"            ..!= False
+        <*> v ..:? "symExecConcolic"    ..!= True
+        <*> v ..:? "symExecTimeout"     ..!= defaultSymExecTimeout
+        <*> v ..:? "symExecNSolvers"    ..!= defaultSymExecNWorkers
+        <*> v ..:? "symExecMaxIters"    ..!= defaultSymExecMaxIters
+        <*> v ..:? "symExecAskSMTIters" ..!= defaultSymExecAskSMTIters
 
       solConfParser = SolConf
         <$> v ..:? "contractAddr"    ..!= defaultContractAddr

lib/Echidna/Output/Corpus.hs

@@ -42,7 +42,7 @@ saveCorpusEvent env (_time, campaignEvent) = do
     Just corpusDir -> saveEvent corpusDir campaignEvent
     Nothing -> pure ()
   where
-    saveEvent dir (WorkerEvent _workerId event) =
+    saveEvent dir (WorkerEvent _workerId _workerType event) =
       maybe (pure ()) (saveFile dir) $ getEventInfo event
     saveEvent _ _ = pure ()
 

lib/Echidna/Server.hs

@@ -16,11 +16,16 @@ import Echidna.Types.Config (Env(..))
 newtype SSE = SSE (LocalTime, CampaignEvent)
 
 instance ToJSON SSE where
-  toJSON (SSE (time, WorkerEvent workerId event)) =
+  toJSON (SSE (time, WorkerEvent workerId workerType event)) =
     object [ "worker" .= workerId
+           , "workerType" .= workerTypeString workerType
            , "timestamp" .= time
            , "data" .= event
            ]
+    where
+      workerTypeString :: WorkerType -> String
+      workerTypeString SymbolicWorker = "symbolic"
+      workerTypeString FuzzWorker = "fuzz"
   toJSON (SSE (time, Failure reason)) =
     object [ "timestamp" .= time
            , "data" .= reason
@@ -38,17 +43,18 @@ runSSEServer serverStopVar env port nworkers = do
         else do
           event@(_, campaignEvent) <- readChan sseChan
           let eventName = \case
-                WorkerEvent _ workerEvent ->
+                WorkerEvent _ _ workerEvent ->
                   case workerEvent of
                     TestFalsified _ -> "test_falsified"
                     TestOptimized _ -> "test_optimized"
                     NewCoverage {} -> "new_coverage"
+                    SymNoNewCoverage -> "sym_no_new_coverage"
                     TxSequenceReplayed {} -> "tx_sequence_replayed"
                     TxSequenceReplayFailed {} -> "tx_sequence_replay_failed"
                     WorkerStopped _ -> "worker_stopped"
                 Failure _err -> "failure"
           case campaignEvent of
-            WorkerEvent _ (WorkerStopped _) -> do
+            WorkerEvent _ _ (WorkerStopped _) -> do
               aliveAfter <- atomicModifyIORef' aliveRef (\n -> (n-1, n-1))
               when (aliveAfter == 0) $ putMVar serverStopVar ()
             _ -> pure ()

lib/Echidna/Solidity.hs

@@ -174,7 +174,7 @@ loadSpecified env name cs = do
   let solConf = env.cfg.solConf
 
   -- Pick contract to load
-  mainContract <- choose cs name
+  mainContract <- chooseContract cs name
   when (isNothing name && length cs > 1 && not solConf.quiet) $
     putStrLn "Multiple contracts found, only analyzing the first"
   unless solConf.quiet $
@@ -220,7 +220,7 @@ loadSpecified env name cs = do
     throwM $ ConstructorArgs (show mainContract.constructorInputs)
 
   -- Select libraries
-  ls <- mapM (choose cs . Just . T.pack) solConf.solcLibs
+  ls <- mapM (chooseContract cs . Just . T.pack) solConf.solcLibs
 
   -- Make sure everything is ready to use, then ship it
   when (null abi) $
@@ -241,7 +241,7 @@ loadSpecified env name cs = do
     vm0 <- deployContracts (zip [addrLibrary ..] ls) solConf.deployer blank
 
     -- additional contract deployment (by name)
-    cs' <- mapM ((choose cs . Just) . T.pack . snd) solConf.deployContracts
+    cs' <- mapM ((chooseContract cs . Just) . T.pack . snd) solConf.deployContracts
     vm1 <- deployContracts (zip (map fst solConf.deployContracts) cs') solConf.deployer vm0
 
     -- additional contract deployment (bytecode)
@@ -275,22 +275,28 @@ loadSpecified env name cs = do
       _ -> pure (vm4, neFuns, fst <$> tests, abiMapping)
 
   where
-    choose [] _ = throwM NoContracts
-    choose (c:_) Nothing = pure c
-    choose _ (Just n) =
-      maybe (throwM $ ContractNotFound n) pure $
-        find (isMatch n) cs
-    isMatch n s =
-      (Data.Text.isSuffixOf (contractId rewriteOsPathSeparators n) . (.contractName)) s ||
-      (Data.Text.isSuffixOf (contractId rewritePosixPathSeparators n) . (.contractName)) s
-    contractId rewrite n
+    setUpFunction = ("setUp", [])
+
+-- | 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
+chooseContract [] _ = throwM NoContracts
+chooseContract (c:_) Nothing = pure c
+chooseContract cs (Just n) =
+  maybe (throwM $ ContractNotFound n) pure $
+    find isMatch cs
+  where
+    isMatch s =
+      (Data.Text.isSuffixOf (contractId rewriteOsPathSeparators) . (.contractName)) s ||
+      (Data.Text.isSuffixOf (contractId rewritePosixPathSeparators) . (.contractName)) s
+    contractId rewrite
       | T.any (== ':') n =
         let (splitPath, splitName) = T.breakOn ":" n
         in rewrite splitPath `T.append` splitName
       | otherwise = ":" `append` n
+
     rewriteOsPathSeparators = T.pack . joinPath . splitDirectories . T.unpack
     rewritePosixPathSeparators = T.pack . FPP.joinPath . FPP.splitDirectories . T.unpack
-    setUpFunction = ("setUp", [])
 
 -- | Given the results of 'loadSolidity', assuming a single-contract test, get everything ready
 -- for running a 'Campaign' against the tests found.