Show events and revert reasons for any failure in the constructor exe…

…cution (crytic#871)

* show events and revert reasons for any failure in the constructor execution

* only perform error decoding when necessary

lib/Echidna/Events.hs

@@ -9,10 +9,11 @@ import Data.Tree.Zipper (fromForest, TreePos, Empty)
 import Data.Text (pack, Text)
 import Data.Map qualified as M
 import Data.Maybe (listToMaybe)
+import Data.Vector (fromList)
 import Control.Lens
 
 import EVM
-import EVM.ABI (Event(..), Indexed(..), decodeAbiValue, AbiType(AbiUIntType))
+import EVM.ABI (Event(..), Indexed(..), decodeAbiValue, AbiType(AbiUIntType, AbiTupleType, AbiStringType))
 import EVM.Concrete (wordValue)
 import EVM.Dapp
 import EVM.Format (showValues, showError, contractNamePart)
@@ -30,8 +31,8 @@ maybeContractNameFromCodeHash codeHash = fmap contractToName maybeContract
   where maybeContract = preview (contextInfo . dappSolcByHash . ix codeHash . _2) ?context
         contractToName = view (contractName . to contractNamePart)
 
-extractEvents :: DappInfo -> VM -> Events
-extractEvents dappInfo' vm =
+extractEvents :: Bool -> DappInfo -> VM -> Events
+extractEvents decodeErrors dappInfo' vm =
   let eventMap = dappInfo' ^. dappEventMap
       forest = traceForest vm
       showTrace trace =
@@ -60,17 +61,18 @@ extractEvents dappInfo' vm =
               _ -> ["merror " <> pack (show e)]
 
           _ -> []
-  in decodeRevert vm ++ concat (concatMap flatten $ fmap (fmap showTrace) forest)
+  in decodeRevert decodeErrors vm ++ concat (concatMap flatten $ fmap (fmap showTrace) forest)
 
 
-decodeRevert :: VM -> Events
-decodeRevert vm =
+decodeRevert :: Bool -> VM -> Events
+decodeRevert decodeErrors vm =
   case vm ^. result of
-    Just (VMFailure (Revert bs)) -> decodeRevertMsg bs
+    Just (VMFailure (Revert bs)) -> decodeRevertMsg decodeErrors bs
     _                            -> []
 
-decodeRevertMsg :: BS.ByteString -> Events
-decodeRevertMsg bs = case BS.splitAt 4 bs of
-                          --"\x08\xc3\x79\xa0" -> Just $ "Error(" ++ (show $ decodeAbiValue AbiStringType (fromStrict $ BS.drop 4 bs)) ++ ")"
-                          ("\x4e\x48\x7b\x71",d) -> ["Panic(" <> (pack . show $ decodeAbiValue (AbiUIntType 256) (fromStrict d)) <> ")"]
-                          _                      -> []
+decodeRevertMsg :: Bool -> BS.ByteString -> Events
+decodeRevertMsg decodeErrors bs =
+  case BS.splitAt 4 bs of
+    ("\x08\xc3\x79\xa0",d) | decodeErrors -> ["Error" <> (pack . show $ decodeAbiValue (AbiTupleType (fromList [AbiStringType])) (fromStrict d))]
+    ("\x4e\x48\x7b\x71",d)                -> ["Panic(" <> (pack . show $ decodeAbiValue (AbiUIntType 256) (fromStrict d)) <> ")"]
+    _                                     -> []

lib/Echidna/Fetch.hs

@@ -7,32 +7,34 @@ import Control.Monad.State.Strict (execStateT)
 import Data.ByteString (ByteString, pack, append)
 import Data.ByteString.Base16 qualified as BS16 (decode)
 import Data.Either (fromRight)
-import Data.Text (Text)
+import Data.Text (Text, unlines)
 import Data.Text.Encoding (encodeUtf8)
 
 import EVM
 import EVM.Solidity
 import EVM.Types (Addr)
+import EVM.Dapp (DappInfo)
 
 import Echidna.Types.Solidity (SolException(..))
 import Echidna.Types.Tx (createTx, unlimitedGasPerBlock)
 import Echidna.Exec (execTx)
+import Echidna.Events (extractEvents)
 
 -- | Deploy a list of solidity contracts in certain addresses
 deployBytecodes' :: (MonadIO m, MonadThrow m)
-                       => [(Addr, ByteString)] -> Addr -> VM -> m VM
-deployBytecodes' []          _ vm = return vm
-deployBytecodes' ((a, bc):cs) d vm = deployBytecodes' cs d =<< loadRest
+                       => DappInfo -> [(Addr, ByteString)] -> Addr -> VM -> m VM
+deployBytecodes' _ []            _ vm = return vm
+deployBytecodes' di ((a, bc):cs) d vm = deployBytecodes' di cs d =<< loadRest
   where zeros = pack $ replicate 320 0 -- This will initialize with zero a large number of possible constructor parameters
         loadRest = do vm' <- execStateT (execTx $ createTx (bc `append` zeros) d a (fromInteger unlimitedGasPerBlock) (0, 0)) vm
                       case vm' ^. result of
                        (Just (VMSuccess _)) -> return vm'
-                       _                    -> throwM $ DeploymentFailed a
+                       _                    -> throwM $ DeploymentFailed a (Data.Text.unlines $ extractEvents True di vm')
 
 deployContracts :: (MonadIO m, MonadThrow m)
-                       => [(Addr, SolcContract)] -> Addr -> VM -> m VM
-deployContracts cs = deployBytecodes' $ map (\(a, c) -> (a, c ^. creationCode)) cs
+                       => DappInfo -> [(Addr, SolcContract)] -> Addr -> VM -> m VM
+deployContracts di cs = deployBytecodes' di $ map (\(a, c) -> (a, c ^. creationCode)) cs
 
 deployBytecodes :: (MonadIO m, MonadThrow m)
-                       => [(Addr, Text)] -> Addr -> VM -> m VM
-deployBytecodes cs = deployBytecodes' $ map (\(a, bc) -> (a, fromRight (error ("invalid b16 decoding of: " ++ show bc)) $ BS16.decode $ encodeUtf8 bc)) cs
+                       => DappInfo -> [(Addr, Text)] -> Addr -> VM -> m VM
+deployBytecodes di cs = deployBytecodes' di $ map (\(a, bc) -> (a, fromRight (error ("invalid b16 decoding of: " ++ show bc)) $ BS16.decode $ encodeUtf8 bc)) cs

lib/Echidna/Solidity.hs

@@ -15,6 +15,7 @@ import Data.List (find, partition, isSuffixOf, (\\))
 import Data.List.NonEmpty qualified as NE
 import Data.List.NonEmpty.Extra qualified as NEE
 import Data.Map (Map, keys, elems, unions, member)
+import Data.Map qualified as Map
 import Data.Maybe (isJust, isNothing, catMaybes, listToMaybe)
 import Data.Text (Text, isPrefixOf, isSuffixOf, append)
 import Data.Text qualified as T
@@ -30,10 +31,11 @@ import EVM qualified (contracts)
 import EVM.ABI
 import EVM.Solidity
 import EVM.Types (Addr, w256)
+import EVM.Dapp (dappInfo)
 
 import Echidna.ABI (encodeSig, encodeSigWithName, hashSig, fallback, commonTypeSizes, mkValidAbiInt, mkValidAbiUInt)
 import Echidna.Exec (execTx, initialVM)
-import Echidna.Events (EventMap)
+import Echidna.Events (EventMap, extractEvents)
 import Echidna.Fetch (deployContracts, deployBytecodes)
 import Echidna.Processor
 import Echidna.RPC (loadEthenoBatch)
@@ -205,20 +207,23 @@ loadSpecified name cs = do
   case find (not . null . snd) tests of
     Just (t,_) -> throwM $ TestArgsFound t                      -- Test args check
     Nothing    -> do
+      -- dappinfo for debugging in case of failure
+      let di = dappInfo "/" (Map.fromList $ map (\x -> (x ^. contractName, x)) cs) mempty
+
       -- library deployment
-      vm0 <- deployContracts (zip [addrLibrary ..] ls) d blank
+      vm0 <- deployContracts di (zip [addrLibrary ..] ls) d blank
 
       -- additional contract deployment (by name)
       cs' <- mapM ((choose cs . Just) . T.pack . snd) dpc
-      vm1 <- deployContracts (zip (map fst dpc) cs') d vm0
+      vm1 <- deployContracts di (zip (map fst dpc) cs') d vm0
 
       -- additional contract deployment (bytecode)
-      vm2 <- deployBytecodes dpb d vm1
+      vm2 <- deployBytecodes di dpb d vm1
 
       -- main contract deployment
       let deployment = execTx $ createTxWithValue bc d ca (fromInteger unlimitedGasPerBlock) (w256 $ fromInteger balc) (0, 0)
       vm3 <- execStateT deployment vm2
-      when (isNothing $ currentContract vm3) (throwM $ DeploymentFailed ca)
+      when (isNothing $ currentContract vm3) (throwM $ DeploymentFailed ca $ T.unlines $ extractEvents True di vm3)
 
       -- Run
       let transaction = execTx $ uncurry basicTx setUpFunction d ca (fromInteger unlimitedGasPerBlock) (0, 0)

lib/Echidna/Test.hs

@@ -148,7 +148,7 @@ checkProperty' (f,a) = do
   (vm, vm') <- runTx f s a
   b  <- gets $ p f . getter
   put vm -- restore EVM state
-  pure (BoolValue b, extractEvents dappInfo vm', getResultFromVM vm')
+  pure (BoolValue b, extractEvents False dappInfo vm', getResultFromVM vm')
 
 --- | Extract a test value from an execution.
 getIntFromResult :: Maybe VMResult -> TestValue
@@ -167,7 +167,7 @@ checkOptimization (f,a) = do
   dappInfo <- view hasLens
   (vm, vm') <- runTx f s a
   put vm -- restore EVM state
-  pure (getIntFromResult (vm' ^. result), extractEvents dappInfo vm', getResultFromVM vm')
+  pure (getIntFromResult (vm' ^. result), extractEvents False dappInfo vm', getResultFromVM vm')
 
 
 checkStatefullAssertion :: (MonadReader x m, Has DappInfo x, MonadState y m, Has VM y, MonadThrow m)
@@ -188,7 +188,7 @@ checkStatefullAssertion (sig, addr) = do
         _ -> False
       -- Test always passes if it doesn't target the last executed contract and function.
       -- Otherwise it passes if it doesn't cause an assertion failure.
-      events = extractEvents dappInfo vm
+      events = extractEvents False dappInfo vm
       eventFailure = not (null events) && (checkAssertionEvent events || checkPanicEvent "1" events)
       isFailure = isCorrectTarget && (eventFailure || isAssertionFailure)
   pure (BoolValue (not isFailure), events, getResultFromVM vm)
@@ -213,7 +213,7 @@ checkDapptestAssertion (sig, addr) = do
         _                            -> False
       isCorrectAddr = addr == vm ^. state . codeContract
       isCorrectTarget = isCorrectFn && isCorrectAddr
-      events = extractEvents dappInfo vm
+      events = extractEvents False dappInfo vm
       isFailure = not hasValue && (isCorrectTarget && isAssertionFailure)
   pure (BoolValue (not isFailure), events, getResultFromVM vm)
 
@@ -223,11 +223,11 @@ checkCall :: (MonadReader x m, Has DappInfo x, MonadState y m, Has VM y, MonadTh
 checkCall f = do
   dappInfo <- view hasLens
   vm <- use hasLens
-  pure (f dappInfo vm, extractEvents dappInfo vm, getResultFromVM vm)
+  pure (f dappInfo vm, extractEvents False dappInfo vm, getResultFromVM vm)
 
 checkAssertionTest :: DappInfo -> VM -> TestValue
 checkAssertionTest dappInfo vm =
-  let events = extractEvents dappInfo vm
+  let events = extractEvents False dappInfo vm
   in BoolValue $ null events || not (checkAssertionEvent events)
 
 checkAssertionEvent :: Events -> Bool
@@ -248,5 +248,5 @@ checkPanicEvent n = any (T.isPrefixOf ("Panic(" <> n <> ")"))
 
 checkOverflowTest :: DappInfo -> VM -> TestValue
 checkOverflowTest dappInfo vm =
-  let es = extractEvents dappInfo vm
+  let es = extractEvents False dappInfo vm
   in BoolValue $ null es || not (checkPanicEvent "17" es)

lib/Echidna/Types/Solidity.hs

@@ -6,7 +6,7 @@ import Control.Exception (Exception)
 import Control.Lens
 import Data.List.NonEmpty qualified as NE
 import Data.SemVer (Version, version, toString)
-import Data.Text (Text)
+import Data.Text (Text, unpack)
 
 import EVM.Solidity
 import EVM.Types (Addr)
@@ -31,7 +31,7 @@ data SolException = BadAddr Addr
                   | NoTests
                   | OnlyTests
                   | ConstructorArgs String
-                  | DeploymentFailed Addr
+                  | DeploymentFailed Addr Text
                   | SetUpCallFailed
                   | NoCryticCompile
                   | InvalidMethodFilters Filter
@@ -54,7 +54,7 @@ instance Show SolException where
     NoCryticCompile          -> "crytic-compile not installed or not found in PATH. To install it, run:\n   pip install crytic-compile"
     (InvalidMethodFilters f) -> "Applying " ++ show f ++ " to the methods produces an empty list. Are you filtering the correct functions or fuzzing the correct contract?"
     SetUpCallFailed          -> "Calling the setUp() funciton failed (revert, out-of-gas, sending ether to an non-payable constructor, etc.)"
-    (DeploymentFailed a)     -> "Deploying the contract " ++ show a ++ " failed (revert, out-of-gas, sending ether to an non-payable constructor, etc.)"
+    (DeploymentFailed a t)   -> "Deploying the contract " ++ show a ++ " failed (revert, out-of-gas, sending ether to an non-payable constructor, etc.):\n" ++ unpack t
     OutdatedSolcVersion v    -> "Solc version " ++ toString v ++ " detected. Echidna doesn't support versions of solc before " ++ toString minSupportedSolcVersion ++ ". Please use a newer version."