Source coverage printing after fuzzing campaign

examples/solidity/basic/flags.sol

@@ -1,20 +1,27 @@
 contract Test {
-  bool private flag0=true;
-  bool private flag1=true;
+  bool private flag0 = true;
+  bool private flag1 = true;
 
   function set0(int val) public returns (bool){
-    if (val % 100 == 0) {flag0 = false;}
+    if (val % 100 == 0) 
+      flag0 = false;
   }
+
   function set1(int val) public returns (bool){
-    if (val % 10 == 0 && !flag0) {flag1 = false;}
+    if (val % 10 == 0 && !flag0) 
+      flag1 = false;
   }
+
   function echidna_alwaystrue() public returns (bool){
     return(true);
   }
+
   function echidna_revert_always() public returns (bool){
     revert();
   }
+
   function echidna_sometimesfalse() public returns (bool){
     return(flag1);
   }
+
 }

lib/Echidna.hs

@@ -11,6 +11,7 @@ import Data.Map.Strict (keys)
 
 import EVM (env, contracts, VM)
 import EVM.ABI (AbiValue(AbiAddress))
+import EVM.Solidity (SourceCache, SolcContract)
 
 import Echidna.ABI
 import Echidna.Config
@@ -20,8 +21,8 @@ import Echidna.Types.Random
 import Echidna.Types.Signature
 import Echidna.Types.Tx
 import Echidna.Types.World
-import Echidna.Transaction
 import Echidna.Processor
+import Echidna.Output.Corpus
 
 import qualified Data.List.NonEmpty as NE
 
@@ -39,12 +40,12 @@ import qualified Data.List.NonEmpty as NE
 -- * A list of transaction sequences to initialize the corpus
 prepareContract :: (MonadCatch m, MonadRandom m, MonadReader x m, MonadIO m, MonadFail m,
                     Has TxConf x, Has SolConf x)
-                => EConfig -> NE.NonEmpty FilePath -> Maybe ContractName -> Seed -> m (VM, World, [SolTest], Maybe GenDict, [[Tx]])
+                => EConfig -> NE.NonEmpty FilePath -> Maybe ContractName -> Seed -> m (VM, SourceCache, [SolcContract], World, [SolTest], Maybe GenDict, [[Tx]])
 prepareContract cfg fs c g = do
   txs <- liftIO $ loadTxs cd
 
   -- compile and load contracts
-  cs <- Echidna.Solidity.contracts fs
+  (cs, sc) <- Echidna.Solidity.contracts fs
   ads <- addresses
   p <- loadSpecified c cs
 
@@ -58,6 +59,6 @@ prepareContract cfg fs c g = do
   let constants' = enhanceConstants si ++ timeConstants ++ largeConstants ++ NE.toList ads ++ ads'
 
   -- start ui and run tests
-  return (v, w, ts, Just $ mkGenDict df constants' [] g (returnTypes cs), txs)
+  return (v, sc, cs, w, ts, Just $ mkGenDict df constants' [] g (returnTypes cs), txs)
   where cd = cfg ^. cConf . corpusDir
         df = cfg ^. cConf . dictFreq

lib/Echidna/Campaign.hs

@@ -161,7 +161,7 @@ execTxOptC t = do
   res <- execTxWith vmExcept (usingCoverage $ pointCoverage cov) t
   let vmr = getResult $ fst res
   -- Update the coverage map with the proper binary according to the vm result
-  cov %= mapWithKey (\_ s -> DS.map (set _2 vmr) s)
+  cov %= mapWithKey (\_ s -> DS.map (set _3 vmr) s)
   -- Update the global coverage map with the union of the result just obtained
   cov %= unionWith DS.union og
   grew <- (== LT) . comparing coveragePoints og <$> use cov

lib/Echidna/Exec.hs

@@ -11,9 +11,10 @@ import Control.Lens
 import Control.Monad.Catch (Exception, MonadThrow(..))
 import Control.Monad.State.Strict (MonadState, execState)
 import Data.Has (Has(..))
+import Data.Maybe (fromMaybe, fromJust)
 import Data.Map.Strict (Map)
-import Data.Maybe (fromMaybe)
 import Data.Set (Set)
+import Data.Tuple.Extra (fst3)
 import EVM
 import EVM.Op (Op(..))
 import EVM.Exec (exec, vmForEthrunCreation)
@@ -99,7 +100,12 @@ execTxWith h m t = do
 execTx :: (MonadState x m, Has VM x, MonadThrow m) => Tx -> m (VMResult, Int)
 execTx = execTxWith vmExcept $ liftSH exec
 
-type CoverageMap = Map BS.ByteString (Set (Int, TxResult))
+-- Program Counter directly obtained from the EVM
+type PC = Int
+-- Index per operation in the source code, obtained from the source mapping 
+type OpIx = Int
+-- Map with the coverage information needed for fuzzing and source code printing 
+type CoverageMap = Map BS.ByteString (Set (PC, OpIx, TxResult))
 
 -- | Given a way of capturing coverage info, execute while doing so once per instruction.
 usingCoverage :: (MonadState x m, Has VM x) => m () -> m VMResult
@@ -113,13 +119,13 @@ coveragePoints = sum . fmap S.size
 -- only considering the different instruction PCs (discarding the TxResult).
 -- This is useful to report a coverage measure to the user
 scoveragePoints :: CoverageMap -> Int
-scoveragePoints = sum . fmap (S.size . S.map fst)
+scoveragePoints = sum . fmap (S.size . S.map fst3)
 
 -- | Capture the current PC and bytecode (without metadata). This should identify instructions uniquely.
 pointCoverage :: (MonadState x m, Has VM x) => Lens' x CoverageMap -> m ()
 pointCoverage l = do
   v <- use hasLens
-  l %= M.insertWith (const . S.insert $ (v ^. state . pc, Success))
+  l %= M.insertWith (const . S.insert $ (v ^. state . pc, fromJust $ vmOpIx v, Success))
                     (fromMaybe (error "no contract information on coverage") $ h v)
                     mempty
   where

lib/Echidna/Output/Corpus.hs

@@ -0,0 +1,34 @@
+module Echidna.Output.Corpus where
+
+import Prelude hiding (Word)
+
+import Control.Monad (unless)
+import Data.Aeson (ToJSON(..), decodeStrict, encodeFile)
+import Data.Hashable (hash)
+import Data.Maybe (catMaybes)
+import System.Directory (createDirectoryIfMissing, makeRelativeToCurrentDirectory, doesFileExist)
+
+import qualified Data.ByteString as BS
+
+import Echidna.Types.Tx
+import Echidna.Output.Utils
+
+saveTxs :: Maybe FilePath -> [[Tx]] -> IO ()
+saveTxs (Just d) txs = mapM_ saveTx txs where
+  saveTx v = do let fn = d ++ "/coverage/" ++ (show . hash . show) v ++ ".txt"
+                b <- doesFileExist fn
+                unless b $ encodeFile fn (toJSON v)
+saveTxs Nothing  _   = pure ()
+
+loadTxs :: Maybe FilePath -> IO [[Tx]]
+loadTxs (Just d) = do
+  let d' = d ++ "/coverage"
+  createDirectoryIfMissing True d' 
+  fs <- listDirectory d'
+  css <- mapM readCall <$> mapM makeRelativeToCurrentDirectory fs
+  txs <- catMaybes <$> withCurrentDirectory d' css
+  putStrLn ("Loaded total of " ++ show (length txs) ++ " transactions from " ++ d')
+  return txs
+  where readCall f = decodeStrict <$> BS.readFile f
+
+loadTxs Nothing  = pure []

lib/Echidna/Output/JSON.hs

@@ -6,6 +6,7 @@ module Echidna.Output.JSON where
 import Echidna.ABI (ppAbiValue, GenDict(..))
 import qualified Echidna.Types.Campaign as C
 import Echidna.Solidity (SolTest)
+import Echidna.Exec (PC, OpIx)
 import Echidna.Types.Tx (Tx(..), TxCall(..), TxResult)
 import Data.Aeson hiding (Error)
 import qualified Data.ByteString.Base16 as BS16
@@ -22,7 +23,7 @@ data Campaign = Campaign
   , _error :: Maybe String
   , _tests :: [Test]
   , seed :: Int
-  , coverage :: Map String [(Int, TxResult)]
+  , coverage :: Map String [(PC, OpIx, TxResult)]
   , gasInfo :: [(Text, (Int, [Tx]))]
   }
 

lib/Echidna/Output/Source.hs

@@ -0,0 +1,121 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+module Echidna.Output.Source where
+
+import Control.Lens
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Text (Text, unlines, pack, unpack)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Text.IO (writeFile)
+import Data.List (nub)
+
+import EVM.Solidity (SourceCache, SrcMap, SolcContract, sourceLines, sourceFiles, runtimeCode, runtimeSrcmap, creationSrcmap)
+import EVM.Debug (srcMapCodePos)
+import Prelude hiding (unlines, writeFile)
+
+import qualified Data.Vector as V
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+import Echidna.Exec 
+import Echidna.Types.Tx
+import Echidna.Types.Signature (getBytecodeMetadata)
+
+type FilePathText = Text
+
+saveCoverage :: Maybe FilePath -> SourceCache -> [SolcContract] -> CoverageMap -> IO ()
+saveCoverage (Just d) sc cs s = let fn = d ++ "/covered.txt"
+                                    cc = ppCoveredCode sc cs s 
+                                in writeFile fn cc
+saveCoverage Nothing  _  _  _ = pure ()
+
+
+-- | Pretty-print the covered code
+ppCoveredCode :: SourceCache -> [SolcContract] -> CoverageMap -> Text
+ppCoveredCode sc cs s | s == mempty = "Coverage map is empty"
+                      | otherwise   =
+  let allLines = M.toList $ sc ^. sourceLines
+  -- ^ Collect all the possible lines from all the files
+      findFile k = fst $ M.findWithDefault ("<no source code>", mempty) k (sc ^. sourceFiles)
+  -- ^ Auxiliary function to get the path for each source file
+      covLines = concatMap (srcMapCov sc s) cs
+  -- ^ List of covered lines during the fuzzing campaing
+  in unlines $ map snd $ concatMap (\(f,vls) ->
+    (mempty, findFile f) :                                                   -- Add a header for each source file to show its complete path
+      filterLines covLines (map ((findFile f,) . decodeUtf8) $ V.toList vls) -- Show the source code for each file with its covered line.
+                                   ) allLines
+
+-- | Filter the lines per file, marking each line
+filterLines :: [Maybe (FilePathText, Int, TxResult)] -> [(FilePathText, Text)] -> [(FilePathText, Text)]
+filterLines []                  ls  = ls
+filterLines (Nothing      : ns) ls  = filterLines ns ls
+filterLines (Just (f,n,r) : ns) ls  = filterLines ns (markLine n r f ls)
+
+-- | Mark one particular line, from a list of lines, keeping the order of them 
+markLine :: Int -> TxResult -> FilePathText -> [(FilePathText, Text)] -> [(FilePathText, Text)] 
+markLine n r cf ls = case splitAt (n-1) ls of
+  (xs, (f,y):ys) | f == cf -> xs ++ [(cf, pack $ markStringLine r $ unpack y)] ++ ys
+  _                        -> map (\(f,y) -> (f, pack $ checkMarkers $ unpack y)) ls
+
+-- | Header preppend to each line
+markerHeader :: String
+markerHeader = "    |"
+
+-- | Add space for markers if necessary
+checkMarkers  :: String -> String
+checkMarkers l@(_:_:_:_:'|':_) = l
+checkMarkers l                 = markerHeader ++ l
+
+-- | Add a proper marker to a line, and convert it to Text
+markStringLine  :: TxResult -> String -> String
+markStringLine r (' ': ' ': ' ': ' ': '|': l) = getMarker r : ' ' : ' ' : ' ': '|' : l
+markStringLine r (m1 : ' ': ' ': ' ': '|': l) = case getMarker r of
+  m | m1 == m -> m1 : ' ' : ' ' : ' ': '|' : l
+  m           -> m1 :  m  : ' ' : ' ': '|' : l
+
+markStringLine r (m1 : m2 : ' ': ' ': '|': l) = case getMarker r of
+  m | m1 == m -> m1 :  m2  : ' ' : ' ': '|' : l
+  m | m2 == m -> m1 :  m2  : ' ' : ' ': '|' : l
+  m           -> m1 :  m2  : m   : ' ': '|' : l
+
+
+markStringLine r (m1 : m2 : m3 : ' ': '|': l) = case getMarker r of
+  m | m1 == m -> m1 :  m2  : m3 : ' ': '|' : l
+  m | m2 == m -> m1 :  m2  : m3 : ' ': '|' : l
+  m | m3 == m -> m1 :  m2  : m3 : ' ': '|' : l
+  m           -> m1 :  m2  : m3 : m  : '|' : l
+
+markStringLine _ (_: _ : _ : _ : '|':_) = error "impossible to add another marker"
+markStringLine r l = getMarker r : ' ' : ' ' : ' ': '|' : l
+
+-- | Select the proper marker, according to the result of the transaction
+getMarker :: TxResult -> Char
+getMarker Success       = '*'
+getMarker ErrorRevert   = 'r' 
+getMarker ErrorOutOfGas = 'o'
+getMarker _             = 'e'
+
+-- | Given a source cache, a coverage map, a contract returns a list of covered lines
+srcMapCov :: SourceCache -> CoverageMap -> SolcContract -> [Maybe (FilePathText, Int, TxResult)]
+srcMapCov sc s c = nub $                                               -- Deduplicate results 
+                   map (srcMapCodePosResult sc) $                      -- Get the filename, number of line and tx result
+                   mapMaybe (srcMapForOpLocation c) $                  -- Get the mapped line and tx result
+                   S.toList $ fromMaybe S.empty $                      -- Convert from Set to list
+                   M.lookup (getBytecodeMetadata $ c ^. runtimeCode) s -- Get the coverage information of the current contract
+
+-- | Given a source cache, a mapped line, return a tuple with the filename, number of line and tx result
+srcMapCodePosResult :: SourceCache -> (SrcMap, TxResult) -> Maybe (Text, Int, TxResult)
+srcMapCodePosResult sc (n, r) = case srcMapCodePos sc n of 
+  Just (t,n') -> Just (t,n',r)
+  _           -> Nothing
+
+-- | Given a contract, and tuple as coverage, return the corresponding mapped line (if any)
+srcMapForOpLocation :: SolcContract -> (Int, Int, TxResult) -> Maybe (SrcMap, TxResult)
+srcMapForOpLocation c (_,n,r) = case preview (ix n) (c ^. runtimeSrcmap <> c ^. creationSrcmap) of
+  Just sm -> Just (sm,r)
+  _       -> Nothing

lib/Echidna/Output/Utils.hs

@@ -0,0 +1,17 @@
+module Echidna.Output.Utils where
+
+import Control.Monad.Catch (bracket)
+import System.Directory (getDirectoryContents, getCurrentDirectory, setCurrentDirectory)
+
+listDirectory :: FilePath -> IO [FilePath]
+listDirectory path = filter f <$> getDirectoryContents path
+  where f filename = filename /= "." && filename /= ".."
+
+withCurrentDirectory :: FilePath  -- ^ Directory to execute in
+                     -> IO a      -- ^ Action to be executed
+                     -> IO a
+withCurrentDirectory dir action =
+  bracket getCurrentDirectory setCurrentDirectory $ \_ -> do
+    setCurrentDirectory dir
+    action
+

lib/Echidna/Solidity.hs

@@ -9,6 +9,7 @@ module Echidna.Solidity where
 
 import Control.Lens
 import Control.Exception          (Exception)
+import Control.Arrow              (first)
 import Control.Monad              (liftM2, when, unless, void)
 import Control.Monad.Catch        (MonadThrow(..))
 import Control.Monad.IO.Class     (MonadIO(..))
@@ -113,7 +114,7 @@ type SolTest = Either (Text, Addr) SolSignature
 -- | Given a list of files, use its extenstion to check if it is a precompiled
 -- contract or try to compile it and get a list of its contracts, throwing
 -- exceptions if necessary.
-contracts :: (MonadIO m, MonadThrow m, MonadReader x m, Has SolConf x) => NE.NonEmpty FilePath -> m [SolcContract]
+contracts :: (MonadIO m, MonadThrow m, MonadReader x m, Has SolConf x) => NE.NonEmpty FilePath -> m ([SolcContract], SourceCache)
 contracts fp = let usual = ["--solc-disable-warnings", "--export-format", "solc"] in do
   mp  <- liftIO $ findExecutable "crytic-compile"
   case mp of
@@ -126,22 +127,26 @@ contracts fp = let usual = ["--solc-disable-warnings", "--export-format", "solc"
     let solargs = a ++ linkLibraries ls & (usual ++) .
                   (\sa -> if null sa then [] else ["--solc-args", sa])
         fps = toList fp
-        compileOne :: (MonadIO m, MonadThrow m, MonadReader x m, Has SolConf x) => FilePath -> m [SolcContract]
+        compileOne :: (MonadIO m, MonadThrow m, MonadReader x m, Has SolConf x) => FilePath -> m ([SolcContract], SourceCache)
         compileOne x = do
           mSolc <- liftIO $ do
             stderr <- if q then UseHandle <$> openFile "/dev/null" WriteMode else pure Inherit
             (ec, out, err) <- readCreateProcessWithExitCode (proc path $ (c ++ solargs) |> x) {std_err = stderr} ""
             case ec of
               ExitSuccess -> readSolc "crytic-export/combined_solc.json"
               ExitFailure _ -> throwM $ CompileFailure out err
-          maybe (throwM SolcReadFailure) (pure . toList . fst) mSolc
-    concat <$> sequence (compileOne <$> fps)
+
+          maybe (throwM SolcReadFailure) (pure . first toList) mSolc
+    cps <- mapM compileOne fps
+    let (cs, ss) = unzip cps
+    when (length ss > 1) $ liftIO $ putStrLn "WARNING: more than one SourceCache was found after compile. Only the first one will be used."
+    pure (concat cs, head ss)
 
 addresses :: (MonadReader x m, Has SolConf x) => m (NE.NonEmpty AbiValue)
 addresses = do
   SolConf{_contractAddr = ca, _deployer = d, _sender = ads} <- view hasLens
   pure $ AbiAddress . fromIntegral <$> NE.nub (join ads [ca, d, 0x0])
-  where join (first NE.:| rest) list = first NE.:| (rest ++ list)
+  where join (f NE.:| r) l = f NE.:| (r ++ l)
 
 populateAddresses :: [Addr] -> Integer -> VM -> VM
 populateAddresses []     _ vm = vm
@@ -209,9 +214,9 @@ loadSpecified name cs = do
   let neFuns = filterMethods (c ^. contractName) fs (fallback NE.:| funs)
 
   -- Construct ABI mapping for World
-  let abiMapping = if ma then M.fromList $ cs <&> \cc -> (cc ^. runtimeCode . to getBytecodeMetadata, filterMethods (cc ^. contractName) fs $ abiOf pref cc)
-                         else M.singleton (c ^. runtimeCode . to getBytecodeMetadata) fabiOfc
-
+  let abiMapping = if ma then M.fromList $ cs <&> \cc -> (getBytecodeMetadata $ cc ^. runtimeCode,  filterMethods (cc ^. contractName) fs $ abiOf pref cc)
+                         else M.singleton (getBytecodeMetadata $ c ^. runtimeCode) fabiOfc
+  
   -- Set up initial VM, either with chosen contract or Etheno initialization file
   -- need to use snd to add to ABI dict
   blank' <- maybe (pure (initialVM & block . gaslimit .~ fromInteger unlimitedGasPerBlock & block . maxCodeSize .~ w256 (fromInteger mcs)))
@@ -252,7 +257,7 @@ loadSpecified name cs = do
 --loadSolidity fp name = contracts fp >>= loadSpecified name
 loadWithCryticCompile :: (MonadIO m, MonadThrow m, MonadReader x m, Has SolConf x, Has TxConf x, MonadFail m)
                       => NE.NonEmpty FilePath -> Maybe Text -> m (VM, EventMap, NE.NonEmpty SolSignature, [Text], SignatureMap)
-loadWithCryticCompile fp name = contracts fp >>= loadSpecified name
+loadWithCryticCompile fp name = contracts fp >>= \(cs, _) -> loadSpecified name cs
 
 
 -- | Given the results of 'loadSolidity', assuming a single-contract test, get everything ready