hevm-0.49.0: src/EVM/Format.hs
{-# Language DataKinds #-}
{-# Language ImplicitParams #-}
{-# Language TemplateHaskell #-}
module EVM.Format where
import Prelude hiding (Word)
import qualified EVM
import EVM.Dapp (DappInfo (..), dappSolcByHash, dappAbiMap, showTraceLocation, dappEventMap, dappErrorMap)
import EVM.Dapp (DappContext (..), contextInfo, contextEnv)
import EVM.Concrete ( wordValue )
import EVM (VM, VMResult(..), cheatCode, traceForest, traceData, Error (..), result)
import EVM (Trace, TraceData (..), Log (..), Query (..), FrameContext (..), Storage(..))
import EVM.SymExec
import EVM.Symbolic (len, litWord)
import EVM.Types (maybeLitWord, Word (..), Whiff(..), SymWord(..), W256 (..), num, word)
import EVM.Types (Addr, Buffer(..), ByteStringS(..))
import EVM.ABI (AbiValue (..), Event (..), AbiType (..), SolError (..))
import EVM.ABI (Indexed (NotIndexed), getAbiSeq)
import EVM.ABI (parseTypeName, formatString)
import EVM.Solidity (SolcContract(..), contractName, abiMap)
import EVM.Solidity (methodOutput, methodSignature, methodName)
import Control.Arrow ((>>>))
import Control.Lens (view, preview, ix, _2, to, makeLenses, over, each, (^?!))
import Data.Binary.Get (runGetOrFail)
import Data.Bits (shiftR)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (byteStringHex, toLazyByteString)
import Data.ByteString.Lazy (toStrict, fromStrict)
import Data.DoubleWord (signedWord)
import Data.Foldable (toList)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text, pack, unpack, intercalate)
import Data.Text (dropEnd, splitOn)
import Data.Text.Encoding (decodeUtf8, decodeUtf8')
import Data.Tree (Tree (Node))
import Data.Tree.View (showTree)
import Data.Vector (Vector)
import Data.Word (Word32)
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Text as Text
data Signedness = Signed | Unsigned
deriving (Show)
showDec :: Signedness -> W256 -> Text
showDec signed (W256 w) =
let
i = case signed of
Signed -> num (signedWord w)
Unsigned -> num w
in
if i == num cheatCode
then "<hevm cheat address>"
else if (i :: Integer) == 2 ^ (256 :: Integer) - 1
then "MAX_UINT256"
else Text.pack (show (i :: Integer))
showWordExact :: Word -> Text
showWordExact (C _ (W256 w)) = humanizeInteger w
showWordExplanation :: W256 -> DappInfo -> Text
showWordExplanation w _ | w > 0xffffffff = showDec Unsigned w
showWordExplanation w dapp =
case Map.lookup (fromIntegral w) (view dappAbiMap dapp) of
Nothing -> showDec Unsigned w
Just x -> "keccak(\"" <> view methodSignature x <> "\")"
humanizeInteger :: (Num a, Integral a, Show a) => a -> Text
humanizeInteger =
Text.intercalate ","
. reverse
. map Text.reverse
. Text.chunksOf 3
. Text.reverse
. Text.pack
. show
showAbiValue :: (?context :: DappContext) => AbiValue -> Text
showAbiValue (AbiBytes _ bs) =
formatBytes bs -- opportunistically decodes recognisable strings
showAbiValue (AbiAddress addr) =
let dappinfo = view contextInfo ?context
contracts = view contextEnv ?context
name = case (Map.lookup addr contracts) of
Nothing -> ""
Just contract ->
let hash = view EVM.codehash contract
solcContract = (preview (dappSolcByHash . ix hash . _2) dappinfo)
in maybeContractName' solcContract
in
name <> "@" <> (pack $ show addr)
showAbiValue v = pack $ show v
showAbiValues :: (?context :: DappContext) => Vector AbiValue -> Text
showAbiValues vs = parenthesise (textAbiValues vs)
textAbiValues :: (?context :: DappContext) => Vector AbiValue -> [Text]
textAbiValues vs = toList (fmap showAbiValue vs)
textValues :: (?context :: DappContext) => [AbiType] -> Buffer -> [Text]
textValues ts (SymbolicBuffer _) = [pack $ show t | t <- ts]
textValues ts (ConcreteBuffer bs) =
case runGetOrFail (getAbiSeq (length ts) ts) (fromStrict bs) of
Right (_, _, xs) -> textAbiValues xs
Left (_, _, _) -> [formatBinary bs]
parenthesise :: [Text] -> Text
parenthesise ts = "(" <> intercalate ", " ts <> ")"
showValues :: (?context :: DappContext) => [AbiType] -> Buffer -> Text
showValues ts b = parenthesise $ textValues ts b
showValue :: (?context :: DappContext) => AbiType -> Buffer -> Text
showValue t b = head $ textValues [t] b
showCall :: (?context :: DappContext) => [AbiType] -> Buffer -> Text
showCall ts (SymbolicBuffer bs) = showValues ts $ SymbolicBuffer (drop 4 bs)
showCall ts (ConcreteBuffer bs) = showValues ts $ ConcreteBuffer (BS.drop 4 bs)
showError :: (?context :: DappContext) => ByteString -> Text
showError bs =
let dappinfo = view contextInfo ?context
bs4 = BS.take 4 bs
in case Map.lookup (word bs4) (view dappErrorMap dappinfo) of
Just (SolError errName ts) -> errName <> " " <> showCall ts (ConcreteBuffer bs)
Nothing -> case bs4 of
-- Method ID for Error(string)
"\b\195y\160" -> showCall [AbiStringType] (ConcreteBuffer bs)
_ -> formatBinary bs
-- the conditions under which bytes will be decoded and rendered as a string
isPrintable :: ByteString -> Bool
isPrintable =
decodeUtf8' >>>
either
(const False)
(Text.all (\c-> Char.isPrint c && (not . Char.isControl) c))
formatBytes :: ByteString -> Text
formatBytes b =
let (s, _) = BS.spanEnd (== 0) b
in
if isPrintable s
then formatBString s
else formatBinary b
formatSBytes :: Buffer -> Text
formatSBytes (SymbolicBuffer b) = "<" <> pack (show (length b)) <> " symbolic bytes>"
formatSBytes (ConcreteBuffer b) = formatBytes b
-- a string that came from bytes, displayed with special quotes
formatBString :: ByteString -> Text
formatBString b = mconcat [ "«", Text.dropAround (=='"') (pack $ formatString b), "»" ]
formatSString :: Buffer -> Text
formatSString (SymbolicBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes (string)>"
formatSString (ConcreteBuffer bs) = pack $ formatString bs
formatBinary :: ByteString -> Text
formatBinary =
(<>) "0x" . decodeUtf8 . toStrict . toLazyByteString . byteStringHex
formatSBinary :: Buffer -> Text
formatSBinary (SymbolicBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes>"
formatSBinary (ConcreteBuffer bs) = formatBinary bs
showTraceTree :: DappInfo -> VM -> Text
showTraceTree dapp vm =
let forest = traceForest vm
traces = fmap (fmap (unpack . showTrace dapp vm)) forest
in pack $ concatMap showTree traces
unindexed :: [(Text, AbiType, Indexed)] -> [AbiType]
unindexed ts = [t | (_, t, NotIndexed) <- ts]
showTrace :: DappInfo -> VM -> Trace -> Text
showTrace dapp vm trace =
let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts }
in let
pos =
case showTraceLocation dapp trace of
Left x -> " \x1b[1m" <> x <> "\x1b[0m"
Right x -> " \x1b[1m(" <> x <> ")\x1b[0m"
fullAbiMap = view dappAbiMap dapp
in case view traceData trace of
EventTrace (Log _ bytes topics) ->
let logn = mconcat
[ "\x1b[36m"
, "log" <> (pack (show (length topics)))
, parenthesise ((map (pack . show) topics) ++ [formatSBinary bytes])
, "\x1b[0m"
] <> pos
knownTopic name types = mconcat
[ "\x1b[36m"
, name
, showValues (unindexed types) bytes
-- todo: show indexed
, "\x1b[0m"
] <> pos
lognote sig usr = mconcat
[ "\x1b[36m"
, "LogNote"
, parenthesise [sig, usr, "..."]
, "\x1b[0m"
] <> pos
in case topics of
[] ->
logn
(t1:_) ->
case maybeLitWord t1 of
Just topic ->
case Map.lookup (wordValue topic) (view dappEventMap dapp) of
Just (Event name _ types) ->
knownTopic name types
Nothing ->
case topics of
[_, t2, _, _] ->
-- check for ds-note logs.. possibly catching false positives
-- event LogNote(
-- bytes4 indexed sig,
-- address indexed usr,
-- bytes32 indexed arg1,
-- bytes32 indexed arg2,
-- bytes data
-- ) anonymous;
let
sig = fromIntegral $ shiftR (wordValue topic) 224 :: Word32
usr = case maybeLitWord t2 of
Just w ->
pack $ show $ (fromIntegral w :: Addr)
Nothing ->
"<symbolic>"
in
case Map.lookup sig (view dappAbiMap dapp) of
Just m ->
lognote (view methodSignature m) usr
Nothing ->
logn
_ ->
logn
Nothing ->
logn
QueryTrace q ->
case q of
PleaseFetchContract addr _ _ ->
"fetch contract " <> pack (show addr) <> pos
PleaseFetchSlot addr slot _ ->
"fetch storage slot " <> pack (show slot) <> " from " <> pack (show addr) <> pos
PleaseAskSMT {} ->
"ask smt" <> pos
PleaseMakeUnique {} ->
"make unique value" <> pos
PleaseDoFFI cmd _ ->
"execute ffi " <> pack (show cmd) <> pos
ErrorTrace e ->
case e of
Revert out ->
"\x1b[91merror\x1b[0m " <> "Revert " <> showError out <> pos
_ ->
"\x1b[91merror\x1b[0m " <> pack (show e) <> pos
ReturnTrace out (CallContext _ _ _ _ _ (Just abi) _ _ _) ->
"← " <>
case Map.lookup (fromIntegral abi) fullAbiMap of
Just m ->
case unzip (view methodOutput m) of
([], []) ->
formatSBinary out
(_, ts) ->
showValues ts out
Nothing ->
formatSBinary out
ReturnTrace out (CallContext {}) ->
"← " <> formatSBinary out
ReturnTrace out (CreationContext {}) ->
"← " <> pack (show (len out)) <> " bytes of code"
EntryTrace t ->
t
FrameTrace (CreationContext addr hash _ _ ) ->
"create "
<> maybeContractName (preview (dappSolcByHash . ix hash . _2) dapp)
<> "@" <> pack (show addr)
<> pos
FrameTrace (CallContext target context _ _ hash abi calldata _ _) ->
let calltype = if target == context
then "call "
else "delegatecall "
in case preview (dappSolcByHash . ix hash . _2) dapp of
Nothing ->
calltype
<> pack (show target)
<> pack "::"
<> case Map.lookup (fromIntegral (fromMaybe 0x00 abi)) fullAbiMap of
Just m ->
"\x1b[1m"
<> view methodName m
<> "\x1b[0m"
<> showCall (catMaybes (getAbiTypes (view methodSignature m))) calldata
Nothing ->
formatSBinary calldata
<> pos
Just solc ->
calltype
<> "\x1b[1m"
<> view (contractName . to contractNamePart) solc
<> "::"
<> maybe "[fallback function]"
(fromMaybe "[unknown method]" . maybeAbiName solc)
abi
<> maybe ("(" <> formatSBinary calldata <> ")")
(\x -> showCall (catMaybes x) calldata)
(abi >>= fmap getAbiTypes . maybeAbiName solc)
<> "\x1b[0m"
<> pos
getAbiTypes :: Text -> [Maybe AbiType]
getAbiTypes abi = map (parseTypeName mempty) types
where
types =
filter (/= "") $
splitOn "," (dropEnd 1 (last (splitOn "(" abi)))
maybeContractName :: Maybe SolcContract -> Text
maybeContractName =
maybe "<unknown contract>" (view (contractName . to contractNamePart))
maybeContractName' :: Maybe SolcContract -> Text
maybeContractName' =
maybe "" (view (contractName . to contractNamePart))
maybeAbiName :: SolcContract -> Word -> Maybe Text
maybeAbiName solc abi = preview (abiMap . ix (fromIntegral abi) . methodSignature) solc
contractNamePart :: Text -> Text
contractNamePart x = Text.split (== ':') x !! 1
contractPathPart :: Text -> Text
contractPathPart x = Text.split (== ':') x !! 0
prettyvmresult :: (?context :: DappContext) => VMResult -> String
prettyvmresult (EVM.VMFailure (EVM.Revert "")) = "Revert"
prettyvmresult (EVM.VMFailure (EVM.Revert msg)) = "Revert" ++ (unpack $ showError msg)
prettyvmresult (EVM.VMFailure (EVM.UnrecognizedOpcode 254)) = "Assertion violation"
prettyvmresult (EVM.VMFailure err) = "Failed: " <> show err
prettyvmresult (EVM.VMSuccess (ConcreteBuffer msg)) =
if BS.null msg
then "Stop"
else "Return: " <> show (ByteStringS msg)
prettyvmresult (EVM.VMSuccess (SymbolicBuffer msg)) =
"Return: " <> show (length msg) <> " symbolic bytes"
currentSolc :: DappInfo -> VM -> Maybe SolcContract
currentSolc dapp vm =
let
this = vm ^?! EVM.env . EVM.contracts . ix (view (EVM.state . EVM.contract) vm)
h = view EVM.codehash this
in
preview (dappSolcByHash . ix h . _2) dapp
-- TODO: display in an 'act' format
-- TreeLine describes a singe line of the tree
-- it contains the indentation which is prefixed to it
-- and its content which contains the rest
data TreeLine = TreeLine {
_indent :: String,
_content :: String
}
makeLenses ''TreeLine
-- SHOW TREE
showTreeIndentSymbol :: Bool -- ^ isLastChild
-> Bool -- ^ isTreeHead
-> String
showTreeIndentSymbol True True = "\x2514" -- └
showTreeIndentSymbol False True = "\x251c" -- ├
showTreeIndentSymbol True False = " "
showTreeIndentSymbol False False = "\x2502" -- │
flattenTree :: Int -> -- total number of cases
Int -> -- case index
Tree [String] ->
[TreeLine]
-- this case should never happen for our use case, here for generality
flattenTree _ _ (Node [] _) = []
flattenTree totalCases i (Node (x:xs) cs) = let
isLastCase = i + 1 == totalCases
indenthead = showTreeIndentSymbol isLastCase True <> " " <> show i <> " "
indentchild = showTreeIndentSymbol isLastCase False <> " "
in TreeLine indenthead x
: ((TreeLine indentchild <$> xs) ++ over (each . indent) ((<>) indentchild) (flattenForest cs))
flattenForest :: [Tree [String]] -> [TreeLine]
flattenForest forest = concat $ zipWith (flattenTree (length forest)) [0..] forest
leftpad :: Int -> String -> String
leftpad n = (<>) $ replicate n ' '
showTree' :: Tree [String] -> String
showTree' (Node s []) = unlines s
showTree' (Node _ children) =
let
treeLines = flattenForest children
maxIndent = 2 + maximum (length . _indent <$> treeLines)
showTreeLine (TreeLine colIndent colContent) =
let indentSize = maxIndent - length colIndent
in colIndent <> leftpad indentSize colContent
in unlines $ showTreeLine <$> treeLines
-- RENDER TREE
showStorage :: [(SymWord, SymWord)] -> [String]
showStorage = fmap (\(k, v) -> show k <> " => " <> show v)
showLeafInfo :: DappInfo -> BranchInfo -> [String]
showLeafInfo srcInfo (BranchInfo vm _) = let
?context = DappContext { _contextInfo = srcInfo, _contextEnv = vm ^?! EVM.env . EVM.contracts }
in let
self = view (EVM.state . EVM.contract) vm
updates = case view (EVM.env . EVM.contracts) vm ^?! ix self . EVM.storage of
Symbolic v _ -> v
Concrete x -> [(litWord k,v) | (k, v) <- Map.toList x]
showResult = [prettyvmresult res | Just res <- [view result vm]]
in showResult
++ showStorage updates
++ [""]
showBranchInfoWithAbi :: DappInfo -> BranchInfo -> [String]
showBranchInfoWithAbi _ (BranchInfo _ Nothing) = [""]
showBranchInfoWithAbi srcInfo (BranchInfo vm (Just y)) =
case y of
(IsZero (Eq (Literal x) _)) ->
let
abimap = view abiMap <$> currentSolc srcInfo vm
method = abimap >>= Map.lookup (num x)
in [maybe (show y) (show . view methodSignature) method]
y' -> [show y']
renderTree :: (a -> [String])
-> (a -> [String])
-> Tree a
-> Tree [String]
renderTree showBranch showLeaf (Node b []) = Node (showBranch b ++ showLeaf b) []
renderTree showBranch showLeaf (Node b cs) = Node (showBranch b) (renderTree showBranch showLeaf <$> cs)