{-# Language LambdaCase #-} module EVM.UnitTest where import Prelude hiding (Word) import EVM import EVM.ABI import EVM.Concrete hiding (readMemoryWord) import EVM.Symbolic import EVM.Dapp import EVM.Debug (srcMapCodePos) import EVM.Exec import EVM.Format import EVM.Solidity import EVM.Types import EVM.VMTest import qualified EVM.Fetch import qualified EVM.FeeSchedule as FeeSchedule import EVM.Stepper (Stepper, interpret) import qualified EVM.Stepper as Stepper import qualified Control.Monad.Operational as Operational import Control.Lens hiding (Indexed) import Control.Monad.State.Strict hiding (state) import qualified Control.Monad.State.Strict as State import Control.Monad.Par.Class (spawn_) import Control.Monad.Par.IO (runParIO) import qualified Data.ByteString.Lazy as BSLazy import Data.ByteString (ByteString) import Data.SBV hiding (verbose) import Data.Either (isRight) import Data.Foldable (toList) import Data.Map (Map) import Data.Maybe (fromMaybe, catMaybes, fromJust, isJust, fromMaybe, mapMaybe) import Data.Monoid ((<>)) import Data.Text (isPrefixOf, stripSuffix, intercalate, Text, pack, unpack) import Data.Word (Word32) import System.Environment (lookupEnv) import System.IO (hFlush, stdout) import qualified Control.Monad.Par.Class as Par import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet import Data.Set (Set) import qualified Data.Set as Set import Data.Vector (Vector) import qualified Data.Vector as Vector import Test.QuickCheck hiding (verbose) data UnitTestOptions = UnitTestOptions { oracle :: Query -> IO (EVM ()) , verbose :: Maybe Int , maxIter :: Maybe Integer , match :: Text , fuzzRuns :: Int , replay :: Maybe (Text, BSLazy.ByteString) , vmModifier :: VM -> VM , dapp :: DappInfo , testParams :: TestVMParams } data TestVMParams = TestVMParams { testAddress :: Addr , testCaller :: Addr , testOrigin :: Addr , testGasCreate :: W256 , testGasCall :: W256 , testBalanceCreate :: W256 , testBalanceCall :: W256 , testCoinbase :: Addr , testNumber :: W256 , testTimestamp :: W256 , testGaslimit :: W256 , testGasprice :: W256 , testMaxCodeSize :: W256 , testDifficulty :: W256 , testChainId :: W256 } defaultGasForCreating :: W256 defaultGasForCreating = 0xffffffffffff defaultGasForInvoking :: W256 defaultGasForInvoking = 0xffffffffffff defaultBalanceForCreator :: W256 defaultBalanceForCreator = 0xffffffffffffffffffffffff defaultBalanceForCreated :: W256 defaultBalanceForCreated = 0xffffffffffffffffffffffff defaultMaxCodeSize :: W256 defaultMaxCodeSize = 0xffffffff type ABIMethod = Text -- | Assuming a constructor is loaded, this stepper will run the constructor -- to create the test contract, give it an initial balance, and run `setUp()'. initializeUnitTest :: UnitTestOptions -> Stepper () initializeUnitTest UnitTestOptions { .. } = do let addr = testAddress testParams Stepper.evm $ do -- Maybe modify the initial VM, e.g. to load library code modify vmModifier -- Make a trace entry for running the constructor pushTrace (EntryTrace "constructor") -- Constructor is loaded; run until it returns code void Stepper.execFully -- Give a balance to the test target Stepper.evm $ do env . contracts . ix addr . balance += w256 (testBalanceCreate testParams) -- Initialize the test contract setupCall testParams "setUp()" emptyAbi popTrace pushTrace (EntryTrace "initialize test") -- Let `setUp()' run to completion res <- Stepper.execFully Stepper.evm $ case res of Left e -> pushTrace (ErrorTrace e) _ -> popTrace -- | Assuming a test contract is loaded and initialized, this stepper -- will run the specified test method and return whether it succeeded. runUnitTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool runUnitTest a method args = do x <- execTest a method args checkFailures a method args x execTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool execTest UnitTestOptions { .. } method args = do -- Set up the call to the test method Stepper.evm $ do setupCall testParams method args pushTrace (EntryTrace method) -- Try running the test method Stepper.execFully >>= \case -- If we failed, put the error in the trace. Left e -> Stepper.evm (pushTrace (ErrorTrace e)) >> pure True _ -> pure False checkFailures :: UnitTestOptions -> ABIMethod -> AbiValue -> Bool -> Stepper Bool checkFailures UnitTestOptions { .. } method args bailed = do -- Decide whether the test is supposed to fail or succeed let shouldFail = "testFail" `isPrefixOf` method if bailed then pure shouldFail else do -- Ask whether any assertions failed Stepper.evm $ do popTrace setupCall testParams "failed()" args res <- Stepper.execFully -- >>= \(ConcreteBuffer bs) -> (Stepper.decode AbiBoolType bs) case res of Right (ConcreteBuffer r) -> let AbiBool failed = decodeAbiValue AbiBoolType (BSLazy.fromStrict r) in pure (shouldFail == failed) _ -> error "internal error: unexpected failure code" -- | Randomly generates the calldata arguments and runs the test fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property fuzzTest opts sig types vm = forAllShow (genAbiValue (AbiTupleType $ Vector.fromList types)) (show . ByteStringS . encodeAbiValue) $ \args -> ioProperty $ fst <$> runStateT (interpret (oracle opts) (runUnitTest opts sig args)) vm tick :: Text -> IO () tick x = Text.putStr x >> hFlush stdout -- | This is like an unresolved source mapping. data OpLocation = OpLocation { srcCodehash :: !W256 , srcOpIx :: !Int } deriving (Eq, Ord, Show) srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap srcMapForOpLocation dapp (OpLocation hash opIx) = case preview (dappSolcByHash . ix hash) dapp of Nothing -> Nothing Just (codeType, solc) -> let vec = case codeType of Runtime -> view runtimeSrcmap solc Creation -> view creationSrcmap solc in preview (ix opIx) vec type CoverageState = (VM, MultiSet OpLocation) currentOpLocation :: VM -> OpLocation currentOpLocation vm = case currentContract vm of Nothing -> error "internal error: why no contract?" Just c -> OpLocation (view codehash c) (fromMaybe (error "internal error: op ix") (vmOpIx vm)) execWithCoverage :: StateT CoverageState IO VMResult execWithCoverage = do _ <- runWithCoverage fromJust <$> use (_1 . result) runWithCoverage :: StateT CoverageState IO VM runWithCoverage = do -- This is just like `exec` except for every instruction evaluated, -- we also increment a counter indexed by the current code location. vm0 <- use _1 case view result vm0 of Nothing -> do vm1 <- zoom _1 (State.state (runState exec1) >> get) zoom _2 (modify (MultiSet.insert (currentOpLocation vm1))) runWithCoverage Just _ -> pure vm0 interpretWithCoverage :: UnitTestOptions -> Stepper a -> StateT CoverageState IO a interpretWithCoverage opts = eval . Operational.view where eval :: Operational.ProgramView Stepper.Action a -> StateT CoverageState IO a eval (Operational.Return x) = pure x eval (action Operational.:>>= k) = case action of Stepper.Exec -> execWithCoverage >>= interpretWithCoverage opts . k Stepper.Run -> runWithCoverage >>= interpretWithCoverage opts . k Stepper.Wait q -> do m <- liftIO (oracle opts q) zoom _1 (State.state (runState m)) >> interpretWithCoverage opts (k ()) Stepper.Ask _ -> error "cannot make choice in this interpreter" Stepper.EVM m -> zoom _1 (State.state (runState m)) >>= interpretWithCoverage opts . k coverageReport :: DappInfo -> MultiSet SrcMap -> Map Text (Vector (Int, ByteString)) coverageReport dapp cov = let sources :: SourceCache sources = view dappSources dapp allPositions :: Set (Text, Int) allPositions = ( Set.fromList . mapMaybe (srcMapCodePos sources) . toList $ mconcat ( view dappSolcByName dapp & Map.elems & map (\x -> view runtimeSrcmap x <> view creationSrcmap x) ) ) srcMapCov :: MultiSet (Text, Int) srcMapCov = MultiSet.mapMaybe (srcMapCodePos sources) cov -- linesByName :: Map Text (Vector ByteString) linesByName = ( Map.fromList . map (\(k, v) -> (fst (fromJust (Map.lookup k (view sourceFiles sources))), v)) . Map.toList $ view sourceLines sources ) f :: Text -> Vector ByteString -> Vector (Int, ByteString) f name = Vector.imap (\i bs -> let n = if Set.member (name, i + 1) allPositions then MultiSet.occur (name, i + 1) srcMapCov else -1 in (n, bs)) in Map.mapWithKey f linesByName coverageForUnitTestContract :: UnitTestOptions -> Map Text SolcContract -> SourceCache -> (Text, [(Text, [AbiType])]) -> IO (MultiSet SrcMap) coverageForUnitTestContract opts@(UnitTestOptions {..}) contractMap sources (name, testNames) = do -- Look for the wanted contract by name from the Solidity info case preview (ix name) contractMap of Nothing -> -- Fail if there's no such contract error $ "Contract " ++ unpack name ++ " not found" Just theContract -> do -- Construct the initial VM and begin the contract's constructor let vm0 = initialUnitTestVm opts theContract (vm1, cov1) <- execStateT (interpretWithCoverage opts (Stepper.enter name >> initializeUnitTest opts)) (vm0, mempty) -- Define the thread spawner for test cases let runOne (testName, _) = spawn_ . liftIO $ do (x, (_, cov)) <- runStateT (interpretWithCoverage opts (runUnitTest opts testName emptyAbi)) (vm1, mempty) pure cov -- Run all the test cases in parallel and gather their coverages covs <- runParIO (mapM runOne testNames >>= mapM Par.get) -- Sum up all the coverage counts let cov2 = MultiSet.unions (cov1 : covs) pure (MultiSet.mapMaybe (srcMapForOpLocation dapp) cov2) runUnitTestContract :: UnitTestOptions -> Map Text SolcContract -> SourceCache -> (Text, [(Text, [AbiType])]) -> IO [(Bool, VM)] runUnitTestContract opts@(UnitTestOptions {..}) contractMap sources (name, testSigs) = do -- Print a header putStrLn $ "Running " ++ show (length testSigs) ++ " tests for " ++ unpack name -- Look for the wanted contract by name from the Solidity info case preview (ix name) contractMap of Nothing -> -- Fail if there's no such contract error $ "Contract " ++ unpack name ++ " not found" Just theContract -> do -- Construct the initial VM and begin the contract's constructor let vm0 = initialUnitTestVm opts theContract vm1 <- execStateT (interpret oracle (Stepper.enter name >> initializeUnitTest opts)) vm0 case view result vm1 of Nothing -> error "internal error: setUp() did not end with a result" Just (VMFailure _) -> do Text.putStrLn "\x1b[31m[FAIL]\x1b[0m setUp()" tick "\n" tick $ failOutput vm1 opts "setUp()" pure [(False, vm1)] Just (VMSuccess _) -> do let runCache :: ([(Either Text Text, VM)], VM) -> (Text, [AbiType]) -> IO ([(Either Text Text, VM)], VM) runCache (results, vm) (testName, types) = do (t, r, vm') <- runTest opts vm (testName, types) Text.putStrLn t let vmCached = vm & set (cache . fetched) (view (cache . fetched) vm') pure (((r, vm'): results), vmCached) -- Run all the test cases and print their status updates, -- accumulating the vm cache throughout (details, _) <- foldM runCache ([], vm1) testSigs let running = [x | (Right x, _) <- details] let bailing = [x | (Left x, _) <- details] tick "\n" tick (Text.unlines (filter (not . Text.null) running)) tick (Text.unlines (filter (not . Text.null) bailing)) pure [(isRight r, vm) | (r, vm) <- details] runTest :: UnitTestOptions -> VM -> (Text, [AbiType]) -> IO (Text, Either Text Text, VM) runTest opts@UnitTestOptions{..} vm (testName, []) = runOne opts vm testName emptyAbi runTest opts@UnitTestOptions{..} vm (testName, types) = case replay of Nothing -> fuzzRun opts vm testName types Just (sig, callData) -> if sig == testName then runOne opts vm testName $ decodeAbiValue (AbiTupleType (Vector.fromList types)) callData else fuzzRun opts vm testName types -- | Define the thread spawner for normal test cases runOne :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Text, Either Text Text, VM) runOne opts@UnitTestOptions{..} vm testName args = do let argInfo = pack (if args == emptyAbi then "" else " with arguments: " <> show args) (bailed, vm') <- runStateT (interpret oracle (execTest opts testName args)) vm (success, vm'') <- runStateT (interpret oracle (checkFailures opts testName args bailed)) vm' if success then let gasSpent = num (testGasCall testParams) - view (state . gas) vm' gasText = pack $ show (fromIntegral gasSpent :: Integer) in pure ("\x1b[32m[PASS]\x1b[0m " <> testName <> argInfo <> " (gas: " <> gasText <> ")" , Right (passOutput vm'' opts testName) , vm'' ) else pure ("\x1b[31m[FAIL]\x1b[0m " <> testName <> argInfo , Left (failOutput vm'' opts testName) , vm'' ) -- | Define the thread spawner for property based tests fuzzRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM) fuzzRun opts@UnitTestOptions{..} vm testName types = do let args = Args{ replay = Nothing , maxSuccess = fuzzRuns , maxDiscardRatio = 10 , maxSize = 100 , chatty = isJust verbose , maxShrinks = maxBound } quickCheckWithResult args (fuzzTest opts testName types vm) >>= \case Success numTests _ _ _ _ _ -> pure ("\x1b[32m[PASS]\x1b[0m " <> testName <> " (runs: " <> (pack $ show numTests) <> ")" -- this isn't the post vm we actually want, as we -- can't retrieve the correct vm from quickcheck , Right (passOutput vm opts testName) , vm ) Failure _ _ _ _ _ _ _ _ _ _ failCase _ _ -> let abiValue = decodeAbiValue (AbiTupleType (Vector.fromList types)) $ BSLazy.fromStrict $ hexText (pack $ concat failCase) ppOutput = pack $ show abiValue in do -- Run the failing test again to get a proper trace vm' <- execStateT (interpret oracle (runUnitTest opts testName abiValue)) vm pure ("\x1b[31m[FAIL]\x1b[0m " <> testName <> ". Counterexample: " <> ppOutput <> "\nRun:\n dapp test --replay '(\"" <> testName <> "\",\"" <> (pack (concat failCase)) <> "\")'\nto test this case again, or \n dapp debug --replay '(\"" <> testName <> "\",\"" <> (pack (concat failCase)) <> "\")'\nto debug it." , Left (failOutput vm' opts testName) , vm' ) _ -> pure ("\x1b[31m[OOPS]\x1b[0m " <> testName , Left (failOutput vm opts testName) , vm ) indentLines :: Int -> Text -> Text indentLines n s = let p = Text.replicate n " " in Text.unlines (map (p <>) (Text.lines s)) passOutput :: VM -> UnitTestOptions -> Text -> Text passOutput vm UnitTestOptions { .. } testName = case verbose of Just 2 -> mconcat [ "Success: " , fromMaybe "" (stripSuffix "()" testName) , "\n" , indentLines 2 (formatTestLogs (view dappEventMap dapp) (view logs vm)) , indentLines 2 (showTraceTree dapp vm) , "\n" ] _ -> "" failOutput :: VM -> UnitTestOptions -> Text -> Text failOutput vm UnitTestOptions { .. } testName = mconcat [ "Failure: " , fromMaybe "" (stripSuffix "()" testName) , "\n" , indentLines 2 (formatTestLogs (view dappEventMap dapp) (view logs vm)) , case verbose of Just _ -> indentLines 2 (showTraceTree dapp vm) _ -> "" ] formatTestLogs :: Map W256 Event -> Seq.Seq Log -> Text formatTestLogs events xs = case catMaybes (toList (fmap (formatTestLog events) xs)) of [] -> "\n" ys -> "\n" <> intercalate "\n" ys <> "\n\n" formatTestLog :: Map W256 Event -> Log -> Maybe Text formatTestLog _ (Log _ _ []) = Nothing formatTestLog events (Log _ args (topic:_)) = case maybeLitWord topic of Nothing -> Nothing Just t -> case (Map.lookup (wordValue t) events) of Nothing -> Nothing Just (Event name _ _) -> case name of "log_bytes32" -> Just $ formatSBytes args "log_named_bytes32" -> let key = grab 32 args val = ditch 32 args in Just $ formatSString key <> ": " <> formatSBytes val "log_named_address" -> let key = grab 32 args val = ditch 44 args in Just $ formatSString key <> ": " <> formatSBinary val "log_named_int" -> let key = grab 32 args val = case maybeLitWord (readMemoryWord 32 args) of Just c -> showDec Signed (wordValue c) Nothing -> "" in Just $ formatSString key <> ": " <> val "log_named_uint" -> let key = grab 32 args val = case maybeLitWord (readMemoryWord 32 args) of Just c -> showDec Unsigned (wordValue c) Nothing -> "" in Just $ formatSString key <> ": " <> val -- TODO: event logs (bytes); -- TODO: event log_named_decimal_int (bytes32 key, int val, uint decimals); -- TODO: event log_named_decimal_uint (bytes32 key, uint val, uint decimals); _ -> Nothing word32Bytes :: Word32 -> ByteString word32Bytes x = BS.pack [byteAt x (3 - i) | i <- [0..3]] setupCall :: TestVMParams -> Text -> AbiValue -> EVM () setupCall TestVMParams{..} sig args = do resetState assign (tx . isCreate) False loadContract testAddress assign (state . calldata) (ConcreteBuffer $ abiMethod sig args, literal . num . BS.length $ abiMethod sig args) assign (state . caller) (litAddr testCaller) assign (state . gas) (w256 testGasCall) origin' <- fromMaybe (initialContract (RuntimeCode mempty)) <$> use (env . contracts . at testOrigin) let originBal = view balance origin' when (originBal <= (w256 testGasprice) * (w256 testGasCall)) $ error "insufficient balance for gas cost" vm <- get put $ initTx vm initialUnitTestVm :: UnitTestOptions -> SolcContract -> VM initialUnitTestVm (UnitTestOptions {..}) theContract = let TestVMParams {..} = testParams vm = makeVm $ VMOpts { vmoptContract = initialContract (InitCode (view creationCode theContract)) , vmoptCalldata = (mempty, 0) , vmoptValue = 0 , vmoptAddress = testAddress , vmoptCaller = litAddr testCaller , vmoptOrigin = testOrigin , vmoptGas = testGasCreate , vmoptGaslimit = testGasCreate , vmoptCoinbase = testCoinbase , vmoptNumber = testNumber , vmoptTimestamp = litWord $ w256 $ testTimestamp , vmoptBlockGaslimit = testGaslimit , vmoptGasprice = testGasprice , vmoptMaxCodeSize = testMaxCodeSize , vmoptDifficulty = testDifficulty , vmoptSchedule = FeeSchedule.istanbul , vmoptChainId = testChainId , vmoptCreate = True , vmoptStorageModel = ConcreteS } creator = initialContract (RuntimeCode mempty) & set nonce 1 & set balance (w256 testBalanceCreate) in vm & set (env . contracts . at ethrunAddress) (Just creator) maybeM :: (Monad m) => b -> (a -> b) -> m (Maybe a) -> m b maybeM def f mayb = do may <- mayb return $ maybe def f may getParametersFromEnvironmentVariables :: Maybe Text -> IO TestVMParams getParametersFromEnvironmentVariables rpc = do block' <- maybeM EVM.Fetch.Latest (EVM.Fetch.BlockNumber . read) (lookupEnv "DAPP_TEST_NUMBER") (miner,ts,blockNum,diff) <- case rpc of Nothing -> return (0,0,0,0) Just url -> EVM.Fetch.fetchBlockFrom block' url >>= \case Nothing -> error $ "Could not fetch block" Just EVM.Block{..} -> return ( _coinbase , wordValue $ forceLit $ _timestamp , wordValue _number , wordValue _difficulty ) let getWord s def = maybe def read <$> lookupEnv s getAddr s def = maybe def read <$> lookupEnv s TestVMParams <$> getAddr "DAPP_TEST_ADDRESS" (createAddress ethrunAddress 1) <*> getAddr "DAPP_TEST_CALLER" ethrunAddress <*> getAddr "DAPP_TEST_ORIGIN" ethrunAddress <*> getWord "DAPP_TEST_GAS_CREATE" defaultGasForCreating <*> getWord "DAPP_TEST_GAS_CALL" defaultGasForInvoking <*> getWord "DAPP_TEST_BALANCE_CREATE" defaultBalanceForCreator <*> getWord "DAPP_TEST_BALANCE_CALL" defaultBalanceForCreated <*> getAddr "DAPP_TEST_COINBASE" miner <*> getWord "DAPP_TEST_NUMBER" blockNum <*> getWord "DAPP_TEST_TIMESTAMP" ts <*> getWord "DAPP_TEST_GAS_LIMIT" 0 <*> getWord "DAPP_TEST_GAS_PRICE" 0 <*> getWord "DAPP_TEST_MAXCODESIZE" defaultMaxCodeSize <*> getWord "DAPP_TEST_DIFFICULTY" diff <*> getWord "DAPP_TEST_CHAINID" 99