diff --git a/ethereum-client-haskell.cabal b/ethereum-client-haskell.cabal --- a/ethereum-client-haskell.cabal +++ b/ethereum-client-haskell.cabal @@ -1,5 +1,5 @@ name: ethereum-client-haskell -version: 0.0.1 +version: 0.0.2 cabal-version: >=1.10 build-type: Simple author: Jamshid @@ -15,7 +15,7 @@ type: git location: https://github.com/jamshidh/ethereum-client-haskell branch: master - tag: v0.0.1 + tag: v0.0.2 executable ethereumH default-language: Haskell98 @@ -45,6 +45,41 @@ , vector , ansi-wl-pprint main-is: Main.hs + other-modules: + Blockchain.BlockChain + Blockchain.BlockSynchronizer + Blockchain.Colors + Blockchain.Communication + Blockchain.Constants + Blockchain.Context + Blockchain.Data.Address + Blockchain.Data.AddressState + Blockchain.Data.Block + Blockchain.Data.GenesisBlock + Blockchain.Data.Peer + Blockchain.Data.SignedTransaction + Blockchain.Data.Transaction + Blockchain.Data.TransactionReceipt + Blockchain.Data.Wire + Blockchain.DB.CodeDB + Blockchain.DB.ModifyStateDB + Blockchain.Display + Blockchain.ExtDBs + Blockchain.ExtendedECDSA + Blockchain.ExtWord + Blockchain.Format + Blockchain.JCommand + Blockchain.PeerUrls + Blockchain.SampleTransactions + Blockchain.SHA + Blockchain.Util + Blockchain.VM.Code + Blockchain.VM.Environment + Blockchain.VM.Labels + Blockchain.VM.Memory + Blockchain.VM.Opcodes + Blockchain.VM.VMState + Blockchain.VM C-sources: fastNonceFinder/nonceFinder.c ghc-options: -Wall buildable: True diff --git a/src/Blockchain/BlockChain.hs b/src/Blockchain/BlockChain.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/BlockChain.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} + +module Blockchain.BlockChain ( + nextDifficulty, + addBlock, + addBlocks, + getBestBlock, + getBestBlockHash, + getGenesisBlockHash + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.State +import Data.Binary hiding (get) +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Functor +import Data.Maybe +import Data.Time +import Data.Time.Clock.POSIX +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Context +import Blockchain.Data.Address +import Blockchain.Data.AddressState +import Blockchain.Data.Block +import Blockchain.Data.RLP +import Blockchain.Data.SignedTransaction +import Blockchain.Data.Transaction +import Blockchain.DB.CodeDB +import Blockchain.Database.MerklePatricia +import Blockchain.DB.ModifyStateDB +import qualified Blockchain.Colors as CL +import Blockchain.Constants +import Blockchain.ExtDBs +import Blockchain.Format +import Blockchain.Data.GenesisBlock +import Blockchain.SHA +import Blockchain.Util +import Blockchain.VM +import Blockchain.VM.Code +import Blockchain.VM.Environment +import Blockchain.VM.VMState + +--import Debug.Trace + +{- +initializeBlockChain::ContextM () +initializeBlockChain = do + let bytes = rlpSerialize $ rlpEncode genesisBlock + blockDBPut (BL.toStrict $ encode $ blockHash $ genesisBlock) bytes + detailsDBPut "best" (BL.toStrict $ encode $ blockHash genesisBlock) +-} + +nextDifficulty::Integer->UTCTime->UTCTime->Integer +nextDifficulty oldDifficulty oldTime newTime = + if round (utcTimeToPOSIXSeconds newTime) >= + (round (utcTimeToPOSIXSeconds oldTime) + 5::Integer) + then oldDifficulty - oldDifficulty `shiftR` 10 + else oldDifficulty + oldDifficulty `shiftR` 10 + +nextGasLimit::Integer->Integer->Integer +nextGasLimit oldGasLimit oldGasUsed = max 125000 ((oldGasLimit * 1023 + oldGasUsed *6 `quot` 5) `quot` 1024) + +checkUnclesHash::Block->Bool +checkUnclesHash b = unclesHash (blockData b) == hash (rlpSerialize $ RLPArray (rlpEncode <$> blockUncles b)) + +--data BlockValidityError = BlockDifficultyWrong Integer Integer | BlockNumberWrong Integer Integer | BlockGasLimitWrong Integer Integer | BlockNonceWrong | BlockUnclesHashWrong +{- +instance Format BlockValidityError where + --format BlockOK = "Block is valid" + format (BlockDifficultyWrong d expected) = "Block difficulty is wrong, is '" ++ show d ++ "', expected '" ++ show expected ++ "'" +-} + +verifyStateRootExists::Block->ContextM Bool +verifyStateRootExists b = do + val <- stateDBGet (BL.toStrict $ encode $ bStateRoot $ blockData b) + case val of + Nothing -> return False + Just _ -> return True + +checkParentChildValidity::(Monad m)=>Block->Block->m () +checkParentChildValidity Block{blockData=c} Block{blockData=p} = do + unless (difficulty c == nextDifficulty (difficulty p) (timestamp p) ( timestamp c)) + $ fail $ "Block difficulty is wrong: got '" ++ show (difficulty c) ++ "', expected '" ++ show (nextDifficulty (difficulty p) (timestamp p) ( timestamp c)) ++ "'" + unless (number c == number p + 1) + $ fail $ "Block number is wrong: got '" ++ show (number c) ++ ", expected '" ++ show (number p + 1) ++ "'" + unless (gasLimit c == nextGasLimit (gasLimit p) (gasUsed p)) + $ fail $ "Block gasLimit is wrong: got '" ++ show (gasLimit c) ++ "', expected '" ++ show (nextGasLimit (gasLimit p) (gasUsed p)) ++ "'" + return () + +checkValidity::Monad m=>Block->ContextM (m ()) +checkValidity b = do + maybeParentBlock <- getBlock (parentHash $ blockData b) + case maybeParentBlock of + Just parentBlock -> do + checkParentChildValidity b parentBlock + unless (nonceIsValid b) $ fail $ "Block nonce is wrong: " ++ format b + unless (checkUnclesHash b) $ fail "Block unclesHash is wrong" + stateRootExists <- verifyStateRootExists b + unless stateRootExists $ fail ("Block stateRoot does not exist: " ++ show (pretty $ bStateRoot $ blockData b)) + return $ return () + Nothing -> fail ("Parent Block does not exist: " ++ show (pretty $ parentHash $ blockData b)) + + +{- + coinbase=prvKey2Address prvKey, + stateRoot = SHA 0x9b109189563315bfeb13d4bfd841b129ff3fd5c85f228a8d9d8563b4dde8432e, + transactionsTrie = 0, +-} + + +runCodeForTransaction::Block->Integer->SignedTransaction->ContextM () +runCodeForTransaction b availableGas t@SignedTransaction{unsignedTransaction=ut@ContractCreationTX{}} = do + liftIO $ putStrLn "runCodeForTransaction: ContractCreationTX" + let tAddr = whoSignedThisTransaction t + + liftIO $ putStrLn $ "availableGas: " ++ show availableGas + + let newAddress = getNewAddress tAddr $ tNonce $ unsignedTransaction t + + liftIO $ putStrLn $ "running code: " ++ tab (CL.magenta ("\n" ++ show (pretty $ tInit ut))) + + pay tAddr (coinbase $ blockData b) (availableGas*gasPrice ut) + + (vmState, newStorageStateRoot) <- + runCodeFromStart tAddr 0 availableGas + Environment{ + envGasPrice=gasPrice ut, + envBlock=b, + envOwner = newAddress, + envOrigin = tAddr, + envInputData = B.empty, --error "envInputData is being used in init", + envSender = tAddr, + envValue = value ut, + envCode = tInit ut + } + + liftIO $ putStrLn "VM has finished running" + + liftIO $ putStrLn $ "gasRemaining: " ++ show (vmGasRemaining vmState) + let usedGas = - vmGasRemaining vmState - refund vmState + liftIO $ putStrLn $ "gasUsed: " ++ show usedGas + pay tAddr (coinbase $ blockData b) (usedGas * gasPrice ut) + + case vmException vmState of + Just e -> do + liftIO $ putStrLn $ CL.red $ show e + putAddressState newAddress + AddressState{ + addressStateNonce=0, + balance=0, + contractRoot=emptyTriePtr, + codeHash=hash B.empty + } + + pay tAddr newAddress (value ut) + Nothing -> do + let result = fromMaybe B.empty $ returnVal vmState + liftIO $ putStrLn $ "Result: " ++ show result + pay tAddr (coinbase $ blockData b) (5*toInteger (B.length result)*gasPrice ut) + liftIO $ putStrLn $ show (pretty newAddress) ++ ": " ++ format result + --cxt <- get + liftIO $ putStrLn $ "adding storage " ++ show (pretty newStorageStateRoot) -- stateRoot $ storageDB cxt) + addCode result + putAddressState newAddress + AddressState{ + addressStateNonce=0, + balance=0, + contractRoot=newStorageStateRoot, + codeHash=hash result + } + + liftIO $ putStrLn $ "paying: " ++ show (value ut) + pay tAddr newAddress (value ut) + +runCodeForTransaction b availableGas t@SignedTransaction{unsignedTransaction=ut@MessageTX{}} = do + liftIO $ putStrLn "runCodeForTransaction: MessageTX" + recipientAddressState <- getAddressState (to ut) + + liftIO $ putStrLn $ "Looking for contract code for: " ++ show (pretty $ to ut) + --liftIO $ putStrLn $ "codeHash is: " ++ show (pretty $ sha2SHAPtr $ codeHash recipientAddressState) + + contractCode <- + fromMaybe B.empty <$> + getCode (codeHash recipientAddressState) + + liftIO $ putStrLn $ "running code: " ++ tab (CL.magenta ("\n" ++ show (pretty (Code contractCode)))) + + let tAddr = whoSignedThisTransaction t + + liftIO $ putStrLn $ "availableGas: " ++ show availableGas + + pay tAddr (coinbase $ blockData b) (availableGas*gasPrice ut) + + pay (whoSignedThisTransaction t) (to ut) (value ut) + + (vmState, newStorageStateRoot) <- + runCodeFromStart (to ut) 0 availableGas + Environment{ + envGasPrice=gasPrice ut, + envBlock=b, + envOwner = to ut, + envOrigin = tAddr, + envInputData = tData ut, + envSender = tAddr, + envValue = value ut, + envCode = Code contractCode + } + + liftIO $ putStrLn $ "newStorageStateRoot: " ++ show (pretty newStorageStateRoot) + + liftIO $ putStrLn $ "gasRemaining: " ++ show (vmGasRemaining vmState) + let usedGas = - vmGasRemaining vmState - refund vmState + liftIO $ putStrLn $ "gasUsed: " ++ show usedGas + pay tAddr (coinbase $ blockData b) (usedGas * gasPrice ut) + + case vmException vmState of + Just e -> do + liftIO $ putStrLn $ CL.red $ show e + --addToBalance tAddr (-value ut) --zombie account, money lost forever + {-addressState <- getAddressState (to ut) + cxt <- get + putAddressState (to ut) + addressState{contractRoot=stateRoot $ storageDB cxt}-} + Nothing -> do + addressState <- getAddressState (to ut) + putAddressState (to ut) addressState{contractRoot=newStorageStateRoot} + return () + + + + + +addBlocks::[Block]->ContextM () +addBlocks blocks = + forM_ blocks addBlock + +isTransactionValid::SignedTransaction->ContextM Bool +isTransactionValid t = do + addressState <- getAddressState $ whoSignedThisTransaction t + return (addressStateNonce addressState == tNonce (unsignedTransaction t)) + +intrinsicGas::Transaction->Integer +intrinsicGas t = zeroLen + 5 * (fromIntegral (codeOrDataLength t) - zeroLen) + 500 + where + zeroLen = fromIntegral $ zeroBytesLength t +--intrinsicGas t@ContractCreationTX{} = 5 * (fromIntegral (codeOrDataLength t)) + 500 + +addTransaction::Block->SignedTransaction->ContextM () +addTransaction b t@SignedTransaction{unsignedTransaction=ut} = do + liftIO $ putStrLn "adding to nonces" + let signAddress = whoSignedThisTransaction t + addNonce signAddress + liftIO $ putStrLn "paying value to recipient" + + let intrinsicGas' = intrinsicGas ut + liftIO $ putStrLn $ "intrinsicGas: " ++ show (intrinsicGas') + --TODO- return here if not enough gas + --liftIO $ putStrLn $ "Paying " ++ show (intrinsicGas' * gasPrice ut) ++ " from " ++ show (pretty signAddress) ++ " to " ++ show (pretty $ coinbase $ blockData b) + pay signAddress (coinbase $ blockData b) (intrinsicGas' * gasPrice ut) + + liftIO $ putStrLn "running code" + runCodeForTransaction b (tGasLimit ut - intrinsicGas') t + +addTransactions::Block->[SignedTransaction]->ContextM () +addTransactions _ [] = return () +addTransactions b (t:rest) = do + valid <- isTransactionValid t + liftIO $ putStrLn $ "Coinbase: " ++ show (pretty $ coinbase $ blockData b) + liftIO $ putStrLn $ "Transaction signed by: " ++ show (pretty $ whoSignedThisTransaction t) + addressState <- getAddressState $ whoSignedThisTransaction t + liftIO $ putStrLn $ "User balance: " ++ show (balance $ addressState) + liftIO $ putStrLn $ "Transaction is valid: " ++ show valid + when valid $ addTransaction b t + addTransactions b rest + +addBlock::Block->ContextM () +addBlock b@Block{blockData=bd, blockUncles=uncles} = do + liftIO $ putStrLn $ "Attempting to insert block #" ++ show (number bd) ++ " (" ++ show (pretty $ blockHash b) ++ ")." + maybeParent <- getBlock $ parentHash bd + case maybeParent of + Nothing -> + liftIO $ putStrLn $ "Missing parent block in addBlock: " ++ show (pretty $ parentHash bd) ++ "\n" ++ + "Block will not be added now, but will be requested and added later" + Just parentBlock -> do + setStateRoot $ bStateRoot $ blockData parentBlock + let rewardBase = 1500 * finney + addToBalance (coinbase bd) rewardBase + + forM_ uncles $ \uncle -> do + addToBalance (coinbase bd) (rewardBase `quot` 32) + addToBalance (coinbase uncle) (rewardBase*15 `quot` 16) + + let transactions = receiptTransactions b + addTransactions b transactions + + ctx <- get + liftIO $ putStrLn $ "newStateRoot: " ++ show (pretty $ stateRoot $ stateDB ctx) + + valid <- checkValidity b + case valid of + Right () -> return () + Left err -> error err + let bytes = rlpSerialize $ rlpEncode b + blockDBPut (BL.toStrict $ encode $ blockHash b) bytes + replaceBestIfBetter b + +getBestBlockHash::ContextM SHA +getBestBlockHash = do + maybeBestHash <- detailsDBGet "best" + case maybeBestHash of + Nothing -> blockHash <$> initializeGenesisBlock + Just bestHash -> return $ decode $ BL.fromStrict $ bestHash + +getGenesisBlockHash::ContextM SHA +getGenesisBlockHash = do + maybeGenesisHash <- detailsDBGet "genesis" + case maybeGenesisHash of + Nothing -> blockHash <$> initializeGenesisBlock + Just bestHash -> return $ decode $ BL.fromStrict $ bestHash + +getBestBlock::ContextM Block +getBestBlock = do + bestBlockHash <- getBestBlockHash + bestBlock <- getBlock bestBlockHash + return $ fromMaybe (error $ "Missing block in database: " ++ show (pretty bestBlockHash)) bestBlock + + +replaceBestIfBetter::Block->ContextM () +replaceBestIfBetter b = do + best <- getBestBlock + if number (blockData best) >= number (blockData b) + then return () + else detailsDBPut "best" (BL.toStrict $ encode $ blockHash b) + diff --git a/src/Blockchain/BlockSynchronizer.hs b/src/Blockchain/BlockSynchronizer.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/BlockSynchronizer.hs @@ -0,0 +1,73 @@ + +module Blockchain.BlockSynchronizer ( + handleNewBlockHashes, + handleNewBlocks + ) where + +import Control.Monad.IO.Class +import Control.Monad.State +import qualified Data.Binary as Bin +import qualified Data.ByteString.Lazy as BL +import Data.Function +import Data.List +import Data.Maybe +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Network.Simple.TCP + +import Blockchain.Data.Block +import Blockchain.BlockChain +import Blockchain.Communication +import Blockchain.Context +import Blockchain.ExtDBs +import Blockchain.SHA +import Blockchain.Data.Wire + +--import Debug.Trace + +data GetBlockHashesResult = NeedMore SHA | NeededHashes [SHA] deriving (Show) + +findFirstHashAlreadyInDB::[SHA]->ContextM (Maybe SHA) +findFirstHashAlreadyInDB hashes = do + items <- filterM (fmap (not . isNothing) . blockDBGet . BL.toStrict . Bin.encode) hashes + return $ safeHead items + where + safeHead::[a]->Maybe a + safeHead [] = Nothing + safeHead (x:_) = Just x + +handleNewBlockHashes::Socket->[SHA]->ContextM () +--handleNewBlockHashes _ list | trace ("########### handleNewBlockHashes: " ++ show list) $ False = undefined +handleNewBlockHashes _ [] = error "handleNewBlockHashes called with empty list" +handleNewBlockHashes socket blockHashes = do + result <- findFirstHashAlreadyInDB blockHashes + case result of + Nothing -> do + --liftIO $ putStrLn "Requesting more block hashes" + cxt <- get + put cxt{neededBlockHashes=reverse blockHashes ++ neededBlockHashes cxt} + sendMessage socket $ GetBlockHashes [last blockHashes] 0x500 + Just hashInDB -> do + liftIO $ putStrLn $ "Found a serverblock already in our database: " ++ show (pretty hashInDB) + cxt <- get + --liftIO $ putStrLn $ show (pretty blockHashes) + put cxt{neededBlockHashes=reverse (takeWhile (/= hashInDB) blockHashes) ++ neededBlockHashes cxt} + askForSomeBlocks socket + +askForSomeBlocks::Socket->ContextM () +askForSomeBlocks socket = do + cxt <- get + if null (neededBlockHashes cxt) + then return () + else do + let (firstBlocks, lastBlocks) = splitAt 0x20 (neededBlockHashes cxt) + put cxt{neededBlockHashes=lastBlocks} + sendMessage socket $ GetBlocks firstBlocks + + +handleNewBlocks::Socket->[Block]->ContextM () +handleNewBlocks socket blocks = do + liftIO $ putStrLn "Submitting new blocks" + addBlocks $ sortBy (compare `on` number . blockData) blocks + liftIO $ putStrLn $ show (length blocks) ++ " blocks have been submitted" + askForSomeBlocks socket diff --git a/src/Blockchain/Colors.hs b/src/Blockchain/Colors.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Colors.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults #-} + +module Blockchain.Colors ( + red, green, yellow, blue, + magenta, cyan, white2, white, black, + bright, dim, underline, blink, Blockchain.Colors.reverse, hidden +) where + + +bright string = "\ESC[1m" ++ string ++ "\ESC[0m" +dim string = "\ESC[2m" ++ string ++ "\ESC[0m" +underline string = "\ESC[4m" ++ string ++ "\ESC[0m" +blink string = "\ESC[5m" ++ string ++ "\ESC[0m" +reverse string = "\ESC[7m" ++ string ++ "\ESC[0m" +hidden string = "\ESC[8m" ++ string ++ "\ESC[0m" + + +black string = "\ESC[30m" ++ string ++ "\ESC[0m" +red string = "\ESC[31m" ++ string ++ "\ESC[0m" +green string = "\ESC[32m" ++ string ++ "\ESC[0m" +yellow string = "\ESC[33m" ++ string ++ "\ESC[0m" +blue string = "\ESC[34m" ++ string ++ "\ESC[0m" +magenta string = "\ESC[35m" ++ string ++ "\ESC[0m" --AKA purple +cyan string = "\ESC[36m" ++ string ++ "\ESC[0m" --AKA aqua +white string = "\ESC[37m" ++ string ++ "\ESC[0m" +white2 string = "\ESC[38m" ++ string ++ "\ESC[0m" diff --git a/src/Blockchain/Communication.hs b/src/Blockchain/Communication.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Communication.hs @@ -0,0 +1,34 @@ + +module Blockchain.Communication ( + sendMessage + ) where + +import Control.Monad.IO.Class +import Data.Binary.Put +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Network.Simple.TCP + +import Blockchain.Data.RLP + +import Blockchain.Context +import Blockchain.Display +import Blockchain.Data.Wire + +ethereumHeader::B.ByteString->Put +ethereumHeader payload = do + putWord32be 0x22400891 + putWord32be $ fromIntegral $ B.length payload + putByteString payload + + + +sendCommand::Socket->B.ByteString->IO () +sendCommand socket payload = do + let theData2 = runPut $ ethereumHeader payload + send socket $ B.concat $ BL.toChunks theData2 + +sendMessage::Socket->Message->ContextM () +sendMessage socket msg = do + displayMessage True msg + liftIO $ sendCommand socket $ rlpSerialize $ wireMessage2Obj msg diff --git a/src/Blockchain/Constants.hs b/src/Blockchain/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Constants.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults #-} + +module Blockchain.Constants where + + +ethVersion::Integer +ethVersion=49 +--ethVersion=45 +--ethVersion=48 +shhVersion::Integer +shhVersion=2 + +_Uether = 1000000000 * 1000000000 * 1000000000 * 1000000000 * 1000000000 * 1000000000; +_Vether = 1000000000 * 1000000000 * 1000000000 * 1000000000 * 1000000000 * 1000000; +_Dether = 1000000000 * 1000000000 * 1000000000 * 1000000000 * 1000000000 * 1000; +_Nether = 1000000000 * 1000000000 * 1000000000 * 1000000000 * 1000000000; +_Yether = 1000000000 * 1000000000 * 1000000000 * 1000000000 * 1000000; +_Zether = 1000000000 * 1000000000 * 1000000000 * 1000000000 * 1000; +_Eether = 1000000000 * 1000000000 * 1000000000 * 1000000000; +_Pether = 1000000000 * 1000000000 * 1000000000 * 1000000; +_Tether = 1000000000 * 1000000000 * 1000000000 * 1000 +_Gether = 1000000000 * 1000000000 * 1000000000 +_Mether = 1000000000 * 1000000000 * 1000000 +_Kether = 1000000000 * 1000000000 * 1000 +ether = 1000000000000000000 +finney = 1000000000000000 +szabo = 1000000000000 +_Gwei = 1000000000 +_Mwei = 1000000 +_Kwei = 1000 +wei = 1 + + +blockDBPath::String +blockDBPath="/blocks/" + +detailsDBPath::String +detailsDBPath="/details/" + +stateDBPath::String +stateDBPath="/state/" + +dbDir::String->String +--dbDir "c" = ".ethereum" +dbDir "c" = "Library/Application Support/Ethereum" +dbDir "h" = ".ethereumH" +dbDir "t" = "/tmp/tmpDB" +dbDir x = error $ "Unknown DB specifier: " ++ show x + + +--"/Users/hutong/Library/Application Support/Ethereum/state/" diff --git a/src/Blockchain/Context.hs b/src/Blockchain/Context.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Context.hs @@ -0,0 +1,83 @@ + +module Blockchain.Context ( + Context(..), + ContextM, + setStateRoot, + setStorageStateRoot, + getStorageStateRoot, + openDBs, + DetailsDB, + BlockDB + ) where + + +import qualified Database.LevelDB as DB + +import Control.Monad.IO.Class +import Control.Monad.State +import Control.Monad.Trans.Resource +import qualified Data.ByteString as B +import System.Directory +import System.FilePath +--import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), ()) + +import Blockchain.Constants +import Blockchain.Database.MerklePatricia +import Blockchain.Data.Peer +import Blockchain.SHA + +--import Debug.Trace + +type BlockDB = DB.DB +type CodeDB = DB.DB +type DetailsDB = DB.DB +type StorageDB = MPDB + +data Context = + Context { + neededBlockHashes::[SHA], + blockDB::BlockDB, + detailsDB::DetailsDB, + stateDB::MPDB, + codeDB::CodeDB, + storageDB::StorageDB, + pingCount::Int, + peers::[Peer] + } + +type ContextM = StateT Context IO + +setStateRoot::SHAPtr->ContextM () +setStateRoot stateRoot' = do + ctx <- get + put ctx{stateDB=(stateDB ctx){stateRoot=stateRoot'}} + +setStorageStateRoot::SHAPtr->ContextM () +setStorageStateRoot stateRoot' = do + ctx <- get + put ctx{storageDB=(storageDB ctx){stateRoot=stateRoot'}} + +getStorageStateRoot::ContextM SHAPtr +getStorageStateRoot = do + ctx <- get + return $ stateRoot $ storageDB ctx + +options::DB.Options +options = DB.defaultOptions { + DB.createIfMissing=True, DB.cacheSize=1024} + +openDBs::String->ResourceT IO Context +openDBs theType = do + homeDir <- liftIO getHomeDirectory + bdb <- DB.open (homeDir dbDir theType ++ blockDBPath) options + ddb <- DB.open (homeDir dbDir theType ++ detailsDBPath) options + sdb <- DB.open (homeDir dbDir theType ++ stateDBPath) options + return $ Context + [] + bdb + ddb + MPDB{ ldb=sdb, stateRoot=error "no stateRoot defined"} + sdb + MPDB{ ldb=sdb, stateRoot=SHAPtr B.empty} --error "no storage stateRoot defined"} + 0 + [] diff --git a/src/Blockchain/DB/CodeDB.hs b/src/Blockchain/DB/CodeDB.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/DB/CodeDB.hs @@ -0,0 +1,20 @@ + +module Blockchain.DB.CodeDB ( + addCode, + getCode + ) where + +import Data.Binary +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +import Blockchain.Context +import Blockchain.ExtDBs +import Blockchain.SHA + +addCode::B.ByteString->ContextM () +addCode = codeDBPut + +getCode::SHA->ContextM (Maybe B.ByteString) +getCode theHash = + codeDBGet (BL.toStrict $ encode $ sha2SHAPtr theHash) diff --git a/src/Blockchain/DB/ModifyStateDB.hs b/src/Blockchain/DB/ModifyStateDB.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/DB/ModifyStateDB.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Blockchain.DB.ModifyStateDB ( + putAddressStates, + addToBalance, + addNonce, + pay +) where + +--import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Context +import Blockchain.Data.Address +import Blockchain.Data.AddressState + +--import Debug.Trace + +putAddressStates::[Address]->AddressState->ContextM () +putAddressStates [] _ = return () +putAddressStates (address:rest) addressState = do + putAddressState address addressState + putAddressStates rest addressState + + +addToBalance::Address->Integer->ContextM () +addToBalance address val = do + addressState <- getAddressState address + putAddressState address addressState{ balance = balance addressState + fromIntegral val } + +addNonce::Address->ContextM () +addNonce address = do + addressState <- getAddressState address + putAddressState address addressState{ addressStateNonce = addressStateNonce addressState + 1 } + +pay::Address->Address->Integer->ContextM () +pay fromAddr toAddr val = do + addToBalance fromAddr (-val) + addToBalance toAddr val + + + + + + + + + + + + + + + + diff --git a/src/Blockchain/Data/Address.hs b/src/Blockchain/Data/Address.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Data/Address.hs @@ -0,0 +1,66 @@ + +module Blockchain.Data.Address ( + Address(..), + prvKey2Address, + pubKey2Address, + getNewAddress + ) where + +import Control.Monad +import qualified Crypto.Hash.SHA3 as C +import Data.Binary +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Maybe +import Network.Haskoin.Crypto hiding (Address) +import Network.Haskoin.Internals hiding (Address) +import Numeric +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Data.RLP +import Blockchain.SHA +import Blockchain.Util + +newtype Address = Address Word160 deriving (Show, Eq) + +instance Pretty Address where + pretty (Address x) = yellow $ text $ padZeros 40 $ showHex x "" + +instance Binary Address where + put (Address x) = sequence_ $ fmap put $ word160ToBytes $ fromIntegral x + get = do + bytes <- replicateM 20 get + let byteString = B.pack bytes + return (Address $ fromInteger $ byteString2Integer byteString) + + +prvKey2Address::PrvKey->Address +prvKey2Address prvKey = + Address $ fromInteger $ byteString2Integer $ C.hash 256 $ BL.toStrict $ encode x `BL.append` encode y + --B16.encode $ hash 256 $ BL.toStrict $ encode x `BL.append` encode y + where + PubKey point = derivePubKey prvKey + x = fromMaybe (error "getX failed in prvKey2Address") $ getX point + y = fromMaybe (error "getY failed in prvKey2Address") $ getY point + +pubKey2Address::PubKey->Address +pubKey2Address (PubKey point) = + Address $ fromInteger $ byteString2Integer $ C.hash 256 $ BL.toStrict $ encode x `BL.append` encode y + --B16.encode $ hash 256 $ BL.toStrict $ encode x `BL.append` encode y + where + x = fromMaybe (error "getX failed in prvKey2Address") $ getX point + y = fromMaybe (error "getY failed in prvKey2Address") $ getY point +pubKey2Address (PubKeyU _) = error "Missing case in pubKey2Address: PubKeyU" + + +instance RLPSerializable Address where + rlpEncode (Address a) = RLPString $ BLC.unpack $ encode a + rlpDecode (RLPString s) = Address $ decode $ BLC.pack s + rlpDecode x = error ("Malformed rlp object sent to rlp2Address: " ++ show x) + +getNewAddress::Address->Integer->Address +getNewAddress a n = + let theHash = hash $ rlpSerialize $ RLPArray [rlpEncode a, rlpEncode n] + in decode $ BL.drop 12 $ encode theHash + diff --git a/src/Blockchain/Data/AddressState.hs b/src/Blockchain/Data/AddressState.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Data/AddressState.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Blockchain.Data.AddressState ( + AddressState(..), + blankAddressState, + getAddressState, + getAllAddressStates, + putAddressState + ) where + +import Data.Binary +import qualified Data.ByteString.Lazy as BL +import Data.Functor +import Data.List +import Numeric +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Data.Address +import qualified Blockchain.Colors as CL +import Blockchain.Context +import Blockchain.ExtDBs +import Blockchain.Format +import qualified Data.NibbleString as N +import Blockchain.Data.RLP +import Blockchain.SHA +import Blockchain.Util + +--import Debug.Trace + +data AddressState = AddressState { addressStateNonce::Integer, balance::Integer, contractRoot::SHAPtr, codeHash::SHA } deriving (Show) + + +blankAddressState::AddressState +blankAddressState = AddressState { addressStateNonce=0, balance=0, contractRoot=emptyTriePtr, codeHash=hash "" } + +instance Format AddressState where + format a = CL.blue "AddressState" ++ + tab("\nnonce: " ++ showHex (addressStateNonce a) "" ++ + "\nbalance: " ++ show (toInteger $ balance a) ++ + "\ncontractRoot: " ++ show (pretty $ contractRoot a) ++ + "\ncodeHash: " ++ show (pretty $ codeHash a)) + +instance RLPSerializable AddressState where + rlpEncode a | balance a < 0 = error $ "Error in cal to rlpEncode for AddressState: AddressState has negative balance: " ++ format a + rlpEncode a = RLPArray [ + rlpEncode $ toInteger $ addressStateNonce a, + rlpEncode $ toInteger $ balance a, + rlpEncode $ contractRoot a, + rlpEncode $ codeHash a + ] + + rlpDecode (RLPArray [n, b, cr, ch]) = + AddressState { + addressStateNonce=fromInteger $ rlpDecode n, + balance=fromInteger $ rlpDecode b, + contractRoot=rlpDecode cr, + codeHash=rlpDecode ch + } + rlpDecode x = error $ "Missing case in rlpDecode for AddressState: " ++ show (pretty x) + +addressAsNibbleString::Address->N.NibbleString +addressAsNibbleString (Address s) = N.EvenNibbleString $ BL.toStrict $ encode s + +getAddressState::Address->ContextM AddressState +getAddressState address = do + states <- getKeyVals $ addressAsNibbleString address + case states of + [] -> return blankAddressState + [state] -> return $ rlpDecode $ rlpDeserialize $ rlpDecode $ snd state + _ -> error ("getAddressStates found multiple states for: " ++ show (pretty address) ++ "\n" ++ intercalate "\n" (show . pretty <$> states)) + + +getAllAddressStates::ContextM [(N.NibbleString, AddressState)] +getAllAddressStates = do + states <- getKeyVals "" + return $ fmap rlpDecode <$> states + + + +putAddressState::Address->AddressState->ContextM () +putAddressState address newState = + putKeyVal (addressAsNibbleString address) $ rlpEncode $ rlpSerialize $ rlpEncode newState + diff --git a/src/Blockchain/Data/Block.hs b/src/Blockchain/Data/Block.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Data/Block.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface #-} + +module Blockchain.Data.Block ( + BlockData(..), + Block(..), + blockHash, + powFunc, + headerHashWithoutNonce, + addNonceToBlock, + findNonce, + fastFindNonce, + nonceIsValid, + getBlock, + putBlock + ) where + +import qualified Crypto.Hash.SHA3 as C +import Data.Binary +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Base16 as B16 +import Data.ByteString.Internal +import Data.Functor +import Data.List +import Data.Maybe +import Data.Time +import Data.Time.Clock.POSIX +import Foreign +import Foreign.ForeignPtr.Unsafe +import Numeric +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Context +import Blockchain.Data.Address +import qualified Blockchain.Colors as CL +import Blockchain.Database.MerklePatricia +import Blockchain.ExtDBs +import Blockchain.Format +import Blockchain.Data.RLP +import Blockchain.SHA +import Blockchain.Data.SignedTransaction +import Blockchain.Util + +--import Debug.Trace + +data BlockData = BlockData { + parentHash::SHA, + unclesHash::SHA, + coinbase::Address, + bStateRoot::SHAPtr, + transactionsRoot::SHAPtr, + receiptsRoot::SHAPtr, + logBloom::B.ByteString, + difficulty::Integer, + number::Integer, + gasLimit::Integer, + gasUsed::Integer, + timestamp::UTCTime, + extraData::Integer, + nonce::SHA +} deriving (Show) + +data Block = Block { + blockData::BlockData, + receiptTransactions::[SignedTransaction], + blockUncles::[BlockData] + } deriving (Show) + +instance Format Block where + format b@Block{blockData=bd, receiptTransactions=receipts, blockUncles=uncles} = + CL.blue ("Block #" ++ show (number bd)) ++ " " ++ + tab (show (pretty $ blockHash b) ++ "\n" ++ + format bd ++ + (if null receipts + then " (no transactions)\n" + else tab (intercalate "\n " (format <$> receipts))) ++ + (if null uncles + then " (no uncles)" + else tab ("Uncles:" ++ tab ("\n" ++ intercalate "\n " (format <$> uncles))))) + +instance RLPSerializable Block where + rlpDecode (RLPArray [bd, RLPArray transactionReceipts, RLPArray uncles]) = + Block (rlpDecode bd) (rlpDecode <$> transactionReceipts) (rlpDecode <$> uncles) + rlpDecode (RLPArray arr) = error ("rlpDecode for Block called on object with wrong amount of data, length arr = " ++ show arr) + rlpDecode x = error ("rlpDecode for Block called on non block object: " ++ show x) + + rlpEncode Block{blockData=bd, receiptTransactions=receipts, blockUncles=uncles} = + RLPArray [rlpEncode bd, RLPArray (rlpEncode <$> receipts), RLPArray $ rlpEncode <$> uncles] + +instance RLPSerializable BlockData where + rlpDecode (RLPArray [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14]) = + BlockData { + parentHash = rlpDecode v1, + unclesHash = rlpDecode v2, + coinbase = rlpDecode v3, + bStateRoot = rlpDecode v4, + transactionsRoot = rlpDecode v5, + receiptsRoot = rlpDecode v6, + logBloom = rlpDecode v7, + difficulty = rlpDecode v8, + number = rlpDecode v9, + gasLimit = rlpDecode v10, + gasUsed = rlpDecode v11, + timestamp = posixSecondsToUTCTime $ fromInteger $ rlpDecode v12, + extraData = rlpDecode v13, + nonce = rlpDecode v14 + } + rlpDecode (RLPArray arr) = error ("Error in rlpDecode for Block: wrong number of items, expected 14, got " ++ show (length arr) ++ ", arr = " ++ show (pretty arr)) + rlpDecode x = error ("rlp2BlockData called on non block object: " ++ show x) + + + rlpEncode bd = + RLPArray [ + rlpEncode $ parentHash bd, + rlpEncode $ unclesHash bd, + rlpEncode $ coinbase bd, + rlpEncode $ bStateRoot bd, + rlpEncode $ transactionsRoot bd, + rlpEncode $ receiptsRoot bd, + rlpEncode $ logBloom bd, + rlpEncode $ difficulty bd, + rlpEncode $ number bd, + rlpEncode $ gasLimit bd, + rlpEncode $ gasUsed bd, + rlpEncode (round $ utcTimeToPOSIXSeconds $ timestamp bd::Integer), + rlpEncode $ extraData bd, + rlpEncode $ nonce bd + ] + +blockHash::Block->SHA +blockHash (Block info _ _) = hash . rlpSerialize . rlpEncode $ info + +instance Format BlockData where + format b = + "parentHash: " ++ show (pretty + $ parentHash b) ++ "\n" ++ + "unclesHash: " ++ show (pretty $ unclesHash b) ++ + (if unclesHash b == hash (B.pack [0xc0]) then " (the empty array)\n" else "\n") ++ + "coinbase: " ++ show (pretty $ coinbase b) ++ "\n" ++ + "stateRoot: " ++ show (pretty $ bStateRoot b) ++ "\n" ++ + "transactionsRoot: " ++ show (pretty $ transactionsRoot b) ++ "\n" ++ + "receiptsRoot: " ++ show (pretty $ receiptsRoot b) ++ "\n" ++ + "difficulty: " ++ show (difficulty b) ++ "\n" ++ + "gasLimit: " ++ show (gasLimit b) ++ "\n" ++ + "gasUsed: " ++ show (gasUsed b) ++ "\n" ++ + "timestamp: " ++ show (timestamp b) ++ "\n" ++ + "extraData: " ++ show (pretty $ extraData b) ++ "\n" ++ + "nonce: " ++ show (pretty $ nonce b) ++ "\n" + +getBlock::SHA->ContextM (Maybe Block) +getBlock h = + fmap (rlpDecode . rlpDeserialize) <$> blockDBGet (BL.toStrict $ encode h) + +putBlock::Block->ContextM () +putBlock b = do + let bytes = rlpSerialize $ rlpEncode b + blockDBPut (BL.toStrict $ encode $ blockHash b) bytes + + +-------------------------- +--Mining stuff + +--used as part of the powFunc +noncelessBlockData2RLP::BlockData->RLPObject +noncelessBlockData2RLP bd = + RLPArray [ + rlpEncode $ parentHash bd, + rlpEncode $ unclesHash bd, + rlpEncode $ coinbase bd, + rlpEncode $ bStateRoot bd, + rlpEncode $ transactionsRoot bd, + rlpEncode $ receiptsRoot bd, + rlpEncode $ logBloom bd, + rlpEncode $ difficulty bd, + rlpEncode $ number bd, + rlpEncode $ gasLimit bd, + rlpEncode $ gasUsed bd, + rlpEncode (round $ utcTimeToPOSIXSeconds $ timestamp bd::Integer), + rlpEncode $ extraData bd + ] + +{- +noncelessBlock2RLP::Block->RLPObject +noncelessBlock2RLP Block{blockData=bd, receiptTransactions=receipts, blockUncles=[]} = + RLPArray [noncelessBlockData2RLP bd, RLPArray (rlpEncode <$> receipts), RLPArray []] +noncelessBlock2RLP _ = error "noncelessBock2RLP not definted for blockUncles /= []" +-} + +sha2ByteString::SHA->B.ByteString +sha2ByteString (SHA val) = BL.toStrict $ encode val + +headerHashWithoutNonce::Block->ByteString +headerHashWithoutNonce b = C.hash 256 $ rlpSerialize $ noncelessBlockData2RLP $ blockData b + +powFunc::Block->Integer +powFunc b = + --trace (show $ headerHashWithoutNonce b) $ + byteString2Integer $ + C.hash 256 ( + headerHashWithoutNonce b + `B.append` + sha2ByteString (nonce $ blockData b)) + +nonceIsValid::Block->Bool +nonceIsValid b = powFunc b * difficulty (blockData b) < (2::Integer)^(256::Integer) + +addNonceToBlock::Block->Integer->Block +addNonceToBlock b n = + b { + blockData=(blockData b) {nonce=SHA $ fromInteger n} + } + +findNonce::Block->Integer +findNonce b = + fromMaybe (error "Huh? You ran out of numbers!!!!") $ + find (nonceIsValid . addNonceToBlock b) [1..] + + +---------- + +fastFindNonce::Block->IO Integer +fastFindNonce b = do + let (theData, _, _) = toForeignPtr $ headerHashWithoutNonce b + let (theThreshold, _, _) = toForeignPtr threshold + retValue <- mallocArray 32 + retInt <- c_fastFindNonce (unsafeForeignPtrToPtr theData) (unsafeForeignPtrToPtr theThreshold) retValue + print retInt + retData <- peekArray 32 retValue + return $ byteString2Integer $ B.pack retData + where + threshold::B.ByteString + threshold = fst $ B16.decode $ BC.pack $ padZeros 64 $ showHex ((2::Integer)^(256::Integer) `quot` difficulty (blockData b)) "" + +foreign import ccall "findNonce" c_fastFindNonce::Ptr Word8->Ptr Word8->Ptr Word8->IO Int +--foreign import ccall "fastFindNonce" c_fastFindNonce::ForeignPtr Word8->ForeignPtr Word8->ForeignPtr Word8 + + +{- +fastFindNonce::Block->Integer +fastFindNonce b = + byteString2Integer $ BC.pack $ + BC.unpack $ + C.hash 256 ( + first `B.append` second) + where + first = headerHashWithoutNonce b + +fastPowFunc::Block->Integer +fastPowFunc b = + --trace (show $ headerHashWithoutNonce b) $ + byteString2Integer $ BC.pack $ + BC.unpack $ + C.hash 256 ( + headerHashWithoutNonce b + `B.append` + sha2ByteString (nonce $ blockData b)) +-} diff --git a/src/Blockchain/Data/GenesisBlock.hs b/src/Blockchain/Data/GenesisBlock.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Data/GenesisBlock.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Blockchain.Data.GenesisBlock ( + initializeGenesisBlock, + initializeStateDB +) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Control.Monad.Trans.State +import qualified Data.ByteString as B +import Data.Functor +import Data.Time.Clock.POSIX + +import Blockchain.Database.MerklePatricia + +import Blockchain.Data.Block +import Blockchain.Context +import Blockchain.Data.Address +import Blockchain.Data.AddressState +import Blockchain.DB.ModifyStateDB +import Blockchain.SHA + +--import Debug.Trace + +--startingRoot::B.ByteString +--(startingRoot, "") = B16.decode "c5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470" + --"bc36789e7a1e281436464229828f817d6612f7b477d66591ff96a9e064bcc98a" + +initializeBlankStateDB::ContextM () +initializeBlankStateDB = do + cxt <- get + liftIO $ runResourceT $ + initializeBlank (stateDB cxt) + put cxt{stateDB=(stateDB cxt){stateRoot=emptyTriePtr}} + +initializeStateDB::ContextM () +initializeStateDB = do + initializeBlankStateDB + + let addresses = Address <$> [ + 0x51ba59315b3a95761d0863b05ccc7a7f54703d99, + 0xe6716f9544a56c530d868e4bfbacb172315bdead, + 0xb9c015918bdaba24b4ff057a92a3873d6eb201be, + 0x1a26338f0d905e295fccb71fa9ea849ffa12aaf4, + 0x2ef47100e0787b915105fd5e3f4ff6752079d5cb, + 0xcd2a3d9f938e13cd947ec05abc7fe734df8dd826, + 0x6c386a4b26f73c802f34673f7248bb118f97424a, + 0xe4157b34ea9615cfbde6b4fda419828124b70c78 + ] + + putAddressStates addresses blankAddressState{balance=0x0100000000000000000000000000000000000000000000000000} + +initializeGenesisBlock::ContextM Block +initializeGenesisBlock = do + initializeStateDB + cxt <- get + let genesisBlock = Block { + blockData = + BlockData { + parentHash = SHA 0, + unclesHash = hash (B.pack [0xc0]), + coinbase = Address 0, + bStateRoot = stateRoot $ stateDB cxt, + transactionsRoot = emptyTriePtr, + receiptsRoot = emptyTriePtr, + logBloom = B.pack [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + difficulty = 0x020000, --1 << 17 + number = 0, + gasLimit = 1000000, + gasUsed = 0, + timestamp = posixSecondsToUTCTime 0, + extraData = 0, + nonce = hash $ B.pack [42] + }, + receiptTransactions=[], + blockUncles=[] + } + putBlock genesisBlock + return genesisBlock + + + + diff --git a/src/Blockchain/Data/Peer.hs b/src/Blockchain/Data/Peer.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Data/Peer.hs @@ -0,0 +1,44 @@ + +module Blockchain.Data.Peer ( + Peer(..) + ) where + +import Data.ByteString.Internal +import Data.Word + +import Blockchain.Format +import Blockchain.Data.RLP + +--import Debug.Trace + + + +--instance Show Block where +-- show x = "" + + + +data IPAddr = IPAddr Word8 Word8 Word8 Word8 deriving (Show) + +instance Format IPAddr where + format (IPAddr v1 v2 v3 v4) = show v1 ++ "." ++ show v2 ++ "." ++ show v3 ++ "." ++ show v4 + +data Peer = Peer { + ipAddr::IPAddr, + peerPort::Word16, + uniqueId::String + } deriving (Show) + +instance Format Peer where + format peer = format (ipAddr peer) ++ ":" ++ show (peerPort peer) + +instance RLPSerializable Peer where + rlpDecode (RLPArray [RLPString [c1,c2,c3,c4], port, RLPString uid]) = + Peer { + ipAddr = IPAddr (c2w c1) (c2w c2) (c2w c3) (c2w c4), + peerPort = fromInteger $ rlpDecode port, + uniqueId = uid + } + rlpDecode x = error ("rlp2Peer called on non block object: " ++ show x) + + rlpEncode = error "rlpEncode undefined for Peer" diff --git a/src/Blockchain/Data/SignedTransaction.hs b/src/Blockchain/Data/SignedTransaction.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Data/SignedTransaction.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Blockchain.Data.SignedTransaction ( + SignedTransaction(..), + signTransaction, + whoSignedThisTransaction + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +import Data.Binary +import Data.ByteString.Internal +import Network.Haskoin.Internals hiding (Address) +import Numeric +--import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.ExtendedECDSA + +import Blockchain.Data.Address +import qualified Blockchain.Colors as CL +import Blockchain.Format +import Blockchain.Data.RLP +import Blockchain.SHA +import Blockchain.Data.Transaction +import Blockchain.Util + +--import Debug.Trace + + +data SignedTransaction = + SignedTransaction { + unsignedTransaction::Transaction, + v::Word8, + r::Integer, + s::Integer + } deriving (Show) + +instance Format SignedTransaction where + format SignedTransaction{unsignedTransaction = x, v=v', r=r', s=s'} = + CL.blue "Transaction" ++ + tab ( + "\n" ++ + format x ++ + "v: " ++ show v' ++ "\n" ++ + "r: " ++ show r' ++ "\n" ++ + "s: " ++ show s' ++ "\n") + +addLeadingZerosTo64::String->String +addLeadingZerosTo64 x = replicate (64 - length x) '0' ++ x + +signTransaction::Monad m=>PrvKey->Transaction->SecretT m SignedTransaction +signTransaction privKey t = do + ExtendedSignature signature yIsOdd <- extSignMsg theHash privKey + + return SignedTransaction{ + unsignedTransaction = t, + v = if yIsOdd then 0x1c else 0x1b, + r = + case B16.decode $ B.pack $ map c2w $ addLeadingZerosTo64 $ showHex (sigR signature) "" of + (val, "") -> byteString2Integer val + _ -> error ("error: sigR is: " ++ showHex (sigR signature) ""), + s = + case B16.decode $ B.pack $ map c2w $ addLeadingZerosTo64 $ showHex (sigS signature) "" of + (val, "") -> byteString2Integer val + _ -> error ("error: sigS is: " ++ showHex (sigS signature) "") + } + where + SHA theHash = hash $ rlpSerialize $ rlpEncode t + + +instance RLPSerializable SignedTransaction where + rlpDecode (RLPArray [n, gp, gl, toAddr, val, i, vVal, rVal, sVal]) = + SignedTransaction { + unsignedTransaction=rlpDecode $ RLPArray [n, gp, gl, toAddr, val, i], + v = fromInteger $ rlpDecode vVal, + r = rlpDecode rVal, + s = rlpDecode sVal + } + rlpDecode x = error ("rlpDecode for Transaction called on non block object: " ++ show x) + + rlpEncode t = + RLPArray [ + n, gp, gl, toAddr, val, i, + rlpEncode $ toInteger $ v t, + rlpEncode $ r t, + rlpEncode $ s t + ] + where + (RLPArray [n, gp, gl, toAddr, val, i]) = rlpEncode (unsignedTransaction t) + +whoSignedThisTransaction::SignedTransaction->Address +whoSignedThisTransaction SignedTransaction{unsignedTransaction=ut, v=v', r=r', s=s'} = + pubKey2Address (getPubKeyFromSignature xSignature theHash) + where + xSignature = ExtendedSignature (Signature (fromInteger r') (fromInteger s')) (0x1c == v') + SHA theHash = hash (rlpSerialize $ rlpEncode ut) diff --git a/src/Blockchain/Data/Transaction.hs b/src/Blockchain/Data/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Data/Transaction.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Blockchain.Data.Transaction ( + Transaction(..), + codeOrDataLength, + zeroBytesLength + ) where + +import qualified Data.ByteString as B +import Text.PrettyPrint.ANSI.Leijen + +import Blockchain.Data.Address +import Blockchain.VM.Code +import qualified Blockchain.Colors as CL +import Blockchain.Format +import Blockchain.Data.RLP +import Blockchain.Util +--import VM + +--import Debug.Trace + + +data Transaction = + MessageTX { + tNonce::Integer, + gasPrice::Integer, + tGasLimit::Integer, + to::Address, + value::Integer, + tData::B.ByteString + } | + ContractCreationTX { + tNonce::Integer, + gasPrice::Integer, + tGasLimit::Integer, + value::Integer, + tInit::Code + } deriving (Show) + +instance Format Transaction where + format MessageTX{tNonce=n, gasPrice=gp, tGasLimit=gl, to=to', value=v, tData=d} = + CL.blue "Message Transaction" ++ + tab ( + "\n" ++ + "tNonce: " ++ show n ++ "\n" ++ + "gasPrice: " ++ show gp ++ "\n" ++ + "tGasLimit: " ++ show gl ++ "\n" ++ + "to: " ++ show (pretty to') ++ "\n" ++ + "value: " ++ show v ++ "\n" ++ + "tData: " ++ tab ("\n" ++ format d) ++ "\n") + format ContractCreationTX{tNonce=n, gasPrice=gp, tGasLimit=gl, value=v, tInit=init'} = + CL.blue "Contract Creation Transaction" ++ + tab ( + "\n" ++ + "tNonce: " ++ show n ++ "\n" ++ + "gasPrice: " ++ show gp ++ "\n" ++ + "tGasLimit: " ++ show gl ++ "\n" ++ + "value: " ++ show v ++ "\n" ++ + "tInit: " ++ tab ("\n" ++ show (pretty init')) ++ "\n") + +instance RLPSerializable Transaction where + rlpDecode (RLPArray [n, gp, gl, RLPString "", val, i]) = + --rlpDecode (RLPArray [n, gp, gl, toAddr, val, i]) | rlpDecode toAddr == (0::Integer) && not (null $ (rlpDecode i::String)) = + ContractCreationTX { + tNonce = rlpDecode n, + gasPrice = rlpDecode gp, + tGasLimit = rlpDecode gl, + value = rlpDecode val, + tInit = rlpDecode i + } + rlpDecode (RLPArray [n, gp, gl, toAddr, val, i]) = + MessageTX { + tNonce = rlpDecode n, + gasPrice = rlpDecode gp, + tGasLimit = rlpDecode gl, + to = rlpDecode toAddr, + value = rlpDecode val, + tData = rlpDecode i + } + rlpDecode x = error ("rlpDecode for Transaction called on non block object: " ++ show x) + + rlpEncode MessageTX{tNonce=n, gasPrice=gp, tGasLimit=gl, to=to', value=v, tData=d} = + RLPArray [ + rlpEncode n, + rlpEncode gp, + rlpEncode gl, + rlpEncode to', + rlpEncode v, + rlpEncode d + ] + rlpEncode ContractCreationTX{tNonce=n, gasPrice=gp, tGasLimit=gl, value=v, tInit=init'} = + RLPArray [ + rlpEncode n, + rlpEncode gp, + rlpEncode gl, + rlpEncode (0::Integer), + rlpEncode v, + rlpEncode init' + ] + +codeOrDataLength::Transaction->Int +codeOrDataLength MessageTX{tData=d} = B.length d +codeOrDataLength ContractCreationTX{tInit=d} = codeLength d + +zeroBytesLength::Transaction->Int +zeroBytesLength MessageTX{tData=d} = length $ filter (==0) $ B.unpack d +zeroBytesLength ContractCreationTX{tInit=Code d} = length $ filter (==0) $ B.unpack d + diff --git a/src/Blockchain/Data/TransactionReceipt.hs b/src/Blockchain/Data/TransactionReceipt.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Data/TransactionReceipt.hs @@ -0,0 +1,68 @@ + +module Blockchain.Data.TransactionReceipt( + TransactionReceipt(..), + PostTransactionState(..) + ) where + +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import qualified Blockchain.Colors as CL +import Blockchain.Format +import Blockchain.SHA +import Blockchain.Data.SignedTransaction +import Blockchain.Data.RLP + +data PostTransactionState = PostTransactionState SHA deriving (Show) + +instance RLPSerializable PostTransactionState where + rlpDecode x = PostTransactionState $ rlpDecode x + rlpEncode (PostTransactionState x) = rlpEncode x + +data TransactionReceipt = + TransactionReceipt { + theTransaction::SignedTransaction, + postTransactionState::PostTransactionState, + cumulativeGasUsed::Integer + } deriving (Show) + + +{- +nonce: 0x, +gasPrice: 0x09184e72a000, --10000000000000 +maxGas: 0x07d0 +to: 0x9f840fe058ce3d84e319b8c747accc1e52f69426 +, 0x +data: 0x00000000000000000000000000000000000000000000000000000000000003e800000000000000000000000000000000000000000000000000000000000007d000000000000000000000000000000000000000000000000000000000000004d2000\ +0000000000000000000000000000000000000000000000000000000000001 +, 0x1b +, 0x7012b0d1998a049ca767541add20b2a185a6eb0452f637ceb566de87056d9f03 +, 0x17f015abaed48196c8d0290bab1aacf82a0e7c02c31618389b2a9990c2731793 +-} + + + + + + +instance Format PostTransactionState where + format (PostTransactionState x) = show $ pretty x + +instance Format TransactionReceipt where + format (TransactionReceipt t p gasUsed) = + CL.blue "TransactionReceipt: " ++ show gasUsed ++ "\n" ++ format t ++ "\nPostTransactionState: " ++ format p + +instance RLPSerializable TransactionReceipt where + rlpDecode (RLPArray [t, pts, gasUsed]) = + TransactionReceipt { + theTransaction = rlpDecode t, + postTransactionState = rlpDecode pts, + cumulativeGasUsed = rlpDecode gasUsed + } + rlpDecode x = error $ "Missing case in rlpDecode for TransactionReceipt: " ++ show (pretty x) + + rlpEncode TransactionReceipt{ + theTransaction=t, + postTransactionState=p, + cumulativeGasUsed=gasUsed} = + RLPArray [rlpEncode t, rlpEncode p, rlpEncode gasUsed] + diff --git a/src/Blockchain/Data/Wire.hs b/src/Blockchain/Data/Wire.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Data/Wire.hs @@ -0,0 +1,264 @@ + +module Blockchain.Data.Wire ( + Message(..), + Capability(..), + obj2WireMessage, + wireMessage2Obj + ) where + +import Data.Functor +import Data.List +import Network.Haskoin.Crypto +import Numeric +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import qualified Blockchain.Colors as CL +import Blockchain.Data.Block +import Blockchain.Data.Peer +import Blockchain.Data.RLP +import Blockchain.Data.SignedTransaction +import Blockchain.Format +import Blockchain.SHA +import Blockchain.Util + +--import Debug.Trace + +data Capability = ETH Integer | SHH Integer deriving (Show) + +name2Cap::Integer->String->Capability +name2Cap qqqq "eth" = ETH qqqq +name2Cap qqqq "shh" = SHH qqqq +name2Cap _ x = error $ "Unknown capability string: " ++ x + +{-capValue::Capability->String +capValue ETH = "eth" +capValue SHH = "shh"-} + +instance RLPSerializable Capability where + rlpEncode (ETH qqqq) = RLPArray [rlpEncode "eth", rlpEncode qqqq] + rlpEncode (SHH qqqq) = RLPArray [rlpEncode "shh", rlpEncode qqqq] + + rlpDecode (RLPArray [name, qqqq]) = name2Cap (rlpDecode qqqq) $ rlpDecode name + rlpDecode x = error $ "wrong format given to rlpDecode for Capability: " ++ show (pretty x) + +data TerminationReason = + DisconnectRequested + | TCPSubSystemError + | BreachOfProtocol + | UselessPeer + | TooManyPeers + | AlreadyConnected + | IncompatibleP2PProtocolVersion + | NullNodeIdentityReceived + | ClientQuitting + | UnexpectedIdentity + | ConnectedToSelf + | PingTimeout + | OtherSubprotocolReason deriving (Show) + + +numberToTerminationReason::Integer->TerminationReason +numberToTerminationReason 0x00 = DisconnectRequested +numberToTerminationReason 0x01 = TCPSubSystemError +numberToTerminationReason 0x02 = BreachOfProtocol +numberToTerminationReason 0x03 = UselessPeer +numberToTerminationReason 0x04 = TooManyPeers +numberToTerminationReason 0x05 = AlreadyConnected +numberToTerminationReason 0x06 = IncompatibleP2PProtocolVersion +numberToTerminationReason 0x07 = NullNodeIdentityReceived +numberToTerminationReason 0x08 = ClientQuitting +numberToTerminationReason 0x09 = UnexpectedIdentity +numberToTerminationReason 0x0a = ConnectedToSelf +numberToTerminationReason 0x0b = PingTimeout +numberToTerminationReason 0x0c = OtherSubprotocolReason +numberToTerminationReason _ = error "numberToTerminationReasion called with unsupported number" + + +terminationReasonToNumber::TerminationReason->Integer +terminationReasonToNumber DisconnectRequested = 0x00 +terminationReasonToNumber TCPSubSystemError = 0x01 +terminationReasonToNumber BreachOfProtocol = 0x02 +terminationReasonToNumber UselessPeer = 0x03 +terminationReasonToNumber TooManyPeers = 0x04 +terminationReasonToNumber AlreadyConnected = 0x05 +terminationReasonToNumber IncompatibleP2PProtocolVersion = 0x06 +terminationReasonToNumber NullNodeIdentityReceived = 0x07 +terminationReasonToNumber ClientQuitting = 0x08 +terminationReasonToNumber UnexpectedIdentity = 0x09 +terminationReasonToNumber ConnectedToSelf = 0x0a +terminationReasonToNumber PingTimeout = 0x0b +terminationReasonToNumber OtherSubprotocolReason = 0x0c + + + +data Message = + Hello { version::Int, clientId::String, capability::[Capability], port::Int, nodeId::Word512 } | + Disconnect TerminationReason | + Ping | + Pong | + GetPeers | + Peers [Peer] | + Status { protocolVersion::Int, networkID::String, totalDifficulty::Int, latestHash::SHA, genesisHash:: SHA } | + QqqqStatus Int | + Transactions [SignedTransaction] | + GetBlocks [SHA] | + Blocks [Block] | + BlockHashes [SHA] | + GetBlockHashes { parentSHAs::[SHA], numChildItems::Integer } | + GetTransactions | + NewBlockPacket Block Integer | + PacketCount Integer | + QqqqPacket | + WhisperProtocolVersion Int deriving (Show) + +instance Format Message where + format Hello{version=ver, clientId=c, capability=cap, port=p, nodeId=n} = + CL.blue "Hello" ++ + " version: " ++ show ver ++ "\n" ++ + " cliendId: " ++ show c ++ "\n" ++ + " capability: " ++ intercalate ", " (show <$> cap) ++ "\n" ++ + " port: " ++ show p ++ "\n" ++ + " nodeId: " ++ take 20 (padZeros 64 (showHex n "")) ++ "...." + format (Disconnect reason) = CL.blue "Disconnect" ++ "(" ++ show reason ++ ")" + format Ping = CL.blue "Ping" + format Pong = CL.blue "Pong" + format GetPeers = CL.blue "GetPeers" + format (Peers peers) = CL.blue "Peers: " ++ intercalate ", " (format <$> peers) + format Status{ protocolVersion=ver, networkID=nID, totalDifficulty=d, latestHash=lh, genesisHash=gh } = + CL.blue "Status" ++ + " protocolVersion: " ++ show ver ++ "\n" ++ + " networkID: " ++ show nID ++ "\n" ++ + " totalDifficulty: " ++ show d ++ "\n" ++ + " latestHash: " ++ show (pretty lh) ++ "\n" ++ + " genesisHash: " ++ show (pretty gh) + format (QqqqStatus ver) = + CL.blue "QqqqStatus " ++ + " protocolVersion: " ++ show ver + format (Transactions transactions) = + CL.blue "Transactions:\n " ++ tab (intercalate "\n " (format <$> transactions)) + +--Short version + format (BlockHashes shas) = + CL.blue "BlockHashes " ++ "(" ++ show (length shas) ++ " new hashes)" +--Long version +{- format (BlockHashes shas) = + CL.blue "BlockHashes:" ++ + tab ("\n" ++ intercalate "\n " (show . pretty <$> shas))-} + + format (GetBlocks shas) = + CL.blue "GetBlocks:" ++ + tab ("\n" ++ intercalate "\n " (show . pretty <$> shas)) + format (Blocks blocks) = CL.blue "Blocks:" ++ tab("\n" ++ intercalate "\n " (format <$> blocks)) + format (GetBlockHashes pSHAs numChild) = + CL.blue "GetBlockHashes" ++ " (max: " ++ show numChild ++ "):\n " ++ + intercalate ",\n " (show . pretty <$> pSHAs) + format (NewBlockPacket block d) = CL.blue "NewBlockPacket" ++ " (" ++ show d ++ ")" ++ tab ("\n" ++ format block) + format (PacketCount c) = + CL.blue "PacketCount:" ++ show c + format QqqqPacket = CL.blue "QqqqPacket" + format GetTransactions = CL.blue "GetTransactions" + format (WhisperProtocolVersion ver) = CL.blue "WhisperProtocolVersion " ++ show ver + + +obj2WireMessage::RLPObject->Message +obj2WireMessage (RLPArray [RLPString "", ver, cId, RLPArray cap, p, nId]) = + Hello (fromInteger $ rlpDecode ver) (rlpDecode cId) (rlpDecode <$> cap) (fromInteger $ rlpDecode p) $ rlp2Word512 nId +obj2WireMessage (RLPArray [RLPScalar 0x01, reason]) = + Disconnect (numberToTerminationReason $ rlpDecode reason) +obj2WireMessage (RLPArray [RLPScalar 0x02]) = Ping +obj2WireMessage (RLPArray [RLPScalar 0x03]) = Pong +obj2WireMessage (RLPArray [RLPScalar 0x04]) = GetPeers +obj2WireMessage (RLPArray (RLPScalar 0x05:peers)) = Peers $ rlpDecode <$> peers +obj2WireMessage (RLPArray [RLPScalar 0x10, ver, nID, d, lh, gh]) = + Status { + protocolVersion=fromInteger $ rlpDecode ver, + networkID = rlpDecode nID, + totalDifficulty = fromInteger $ rlpDecode d, + latestHash=rlpDecode lh, + genesisHash=rlpDecode gh +} +obj2WireMessage (RLPArray [RLPScalar 0x10, ver]) = + QqqqStatus $ fromInteger $ rlpDecode ver + +obj2WireMessage (RLPArray [RLPScalar 0x11]) = GetTransactions +obj2WireMessage (RLPArray (RLPScalar 0x12:transactions)) = + Transactions $ rlpDecode <$> transactions + + +obj2WireMessage (RLPArray (RLPScalar 0x13:items)) = + GetBlockHashes (rlpDecode <$> init items) $ rlpDecode $ last items +obj2WireMessage (RLPArray (RLPScalar 0x14:items)) = + BlockHashes $ rlpDecode <$> items + + +obj2WireMessage (RLPArray (RLPScalar 0x15:items)) = + GetBlocks $ rlpDecode <$> items +obj2WireMessage (RLPArray (RLPScalar 0x16:blocks)) = + Blocks $ rlpDecode <$> blocks +obj2WireMessage (RLPArray [RLPScalar 0x17, block, td]) = + NewBlockPacket (rlpDecode block) (rlpDecode td) +obj2WireMessage (RLPArray [RLPScalar 0x18, c]) = + PacketCount $ rlpDecode c +obj2WireMessage (RLPArray [RLPScalar 0x19]) = + QqqqPacket + +obj2WireMessage (RLPArray [RLPScalar 0x20, ver]) = + WhisperProtocolVersion $ fromInteger $ rlpDecode ver + +obj2WireMessage x = error ("Missing case in obj2WireMessage: " ++ show (pretty x)) + + + + + + +wireMessage2Obj::Message->RLPObject +wireMessage2Obj Hello { version = ver, + clientId = cId, + capability = cap, + port = p, + nodeId = nId } = + RLPArray [ + RLPString [], + rlpEncode $ toInteger ver, + rlpEncode cId, + RLPArray $ rlpEncode <$> cap, + rlpEncode $ toInteger p, + word5122RLP nId + ] +wireMessage2Obj (Disconnect reason) = + RLPArray [RLPScalar 0x1, rlpEncode $ terminationReasonToNumber reason] +wireMessage2Obj Ping = RLPArray [RLPScalar 0x2] +wireMessage2Obj Pong = RLPArray [RLPScalar 0x3] +wireMessage2Obj GetPeers = RLPArray [RLPScalar 0x4] +wireMessage2Obj (Peers peers) = RLPArray $ RLPScalar 0x5:(rlpEncode <$> peers) + +wireMessage2Obj (Status ver nID d lh gh) = + RLPArray [RLPScalar 0x10, rlpEncode $ toInteger ver, rlpEncode nID, rlpEncode $ toInteger d, rlpEncode lh, rlpEncode gh] +wireMessage2Obj (QqqqStatus ver) = + RLPArray [RLPScalar 0x10, rlpEncode $ toInteger ver] +wireMessage2Obj GetTransactions = RLPArray [RLPScalar 0x11] +wireMessage2Obj (Transactions transactions) = + RLPArray (RLPScalar 0x12:(rlpEncode <$> transactions)) +wireMessage2Obj (GetBlockHashes pSHAs numChildren) = + RLPArray $ [RLPScalar 0x13] ++ + (rlpEncode <$> pSHAs) ++ + [rlpEncode numChildren] +wireMessage2Obj (BlockHashes shas) = + RLPArray $ RLPScalar 0x14:(rlpEncode <$> shas) +wireMessage2Obj (GetBlocks shas) = + RLPArray $ RLPScalar 0x15:(rlpEncode <$> shas) +wireMessage2Obj (Blocks blocks) = + RLPArray (RLPScalar 0x16:(rlpEncode <$> blocks)) +wireMessage2Obj (NewBlockPacket block d) = + RLPArray [RLPScalar 0x17, rlpEncode block, rlpEncode d] +wireMessage2Obj (PacketCount c) = + RLPArray [RLPScalar 0x18, rlpEncode c] +wireMessage2Obj QqqqPacket = + RLPArray [RLPScalar 0x19] + +wireMessage2Obj (WhisperProtocolVersion ver) = + RLPArray [RLPScalar 0x20, rlpEncode $ toInteger ver] + + + diff --git a/src/Blockchain/Display.hs b/src/Blockchain/Display.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Display.hs @@ -0,0 +1,61 @@ + +module Blockchain.Display ( + addPingCount, + setPeers, + displayMessage + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.State + +import qualified Blockchain.Colors as CL +import Blockchain.Context +import Blockchain.Data.Peer +import Blockchain.Format +import Blockchain.Data.Wire + +setTitle::String->IO() +setTitle value = do + putStr $ "\ESC]0;" ++ value ++ "\007" + +updateStatus::ContextM () +updateStatus = do + cxt <- get + liftIO $ setTitle $ + "pingCount = " ++ show (pingCount cxt) + ++ ", peer count=" ++ show (length $ peers cxt) + ++ ", hashes requested=" ++ show (length $ neededBlockHashes cxt) + +addPingCount::ContextM () +addPingCount = do + cxt <- get + put cxt{pingCount = pingCount cxt + 1} + updateStatus + +setPeers::[Peer]->ContextM () +setPeers p = do + cxt <- get + put cxt{peers = p} + updateStatus + +prefix::Bool->String +prefix True = CL.green "msg>>>>>: " +prefix False = CL.red "msg<<<<: " + + +displayMessage::Bool->Message->ContextM () +displayMessage _ Ping = return () +displayMessage _ Pong = return () +displayMessage _ GetPeers = return () +displayMessage _ (Peers _) = return () +displayMessage _ (GetBlocks blocks) = do + liftIO $ putStrLn $ CL.blue "GetBlocks: " ++ "(Requesting " ++ show (length blocks) ++ " blocks)" +displayMessage _ QqqqPacket = return () +displayMessage outbound (BlockHashes shas) = do + liftIO $ putStrLn $ prefix outbound ++ CL.blue "BlockHashes: " ++ "(" ++ show (length shas) ++ " new hashes)" + updateStatus +displayMessage outbound (Blocks blocks) = do + liftIO $ putStrLn $ prefix outbound ++ CL.blue "Blocks: " ++ "(" ++ show (length blocks) ++ " new blocks)" + updateStatus +displayMessage outbound msg = + liftIO $ putStrLn $ (prefix outbound) ++ format msg diff --git a/src/Blockchain/ExtDBs.hs b/src/Blockchain/ExtDBs.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/ExtDBs.hs @@ -0,0 +1,120 @@ + +module Blockchain.ExtDBs ( + MP.SHAPtr(..), + MP.emptyTriePtr, + detailsDBPut, + detailsDBGet, + blockDBGet, + blockDBPut, + codeDBGet, + codeDBPut, + stateDBPut, + stateDBGet, + putKeyVal, + getKeyVals, + deleteStorageKey, + putStorageKeyVal, + getStorageKeyVals + ) where + +import Control.Monad.State +import Control.Monad.Trans.Resource +import Data.Binary hiding (get, put) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Default +import qualified Database.LevelDB as DB +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import qualified Data.NibbleString as N +import Blockchain.SHA +import Blockchain.Data.RLP +import qualified Blockchain.Database.MerklePatricia as MP + +import Blockchain.Context + +--import Debug.Trace + +detailsDBPut::B.ByteString->B.ByteString->ContextM () +detailsDBPut key val = do + ctx <- get + runResourceT $ + DB.put (detailsDB ctx) def key val + +detailsDBGet::B.ByteString->ContextM (Maybe B.ByteString) +detailsDBGet key = do + ctx <- get + runResourceT $ + DB.get (detailsDB ctx) def key + +blockDBPut::B.ByteString->B.ByteString->ContextM () +blockDBPut key val = do + ctx <- get + runResourceT $ + DB.put (blockDB ctx) def key val + +blockDBGet::B.ByteString->ContextM (Maybe B.ByteString) +blockDBGet key = do + ctx <- get + runResourceT $ + DB.get (blockDB ctx) def key + + +codeDBPut::B.ByteString->ContextM () +codeDBPut code = do + ctx <- get + runResourceT $ + DB.put (codeDB ctx) def (BL.toStrict $ encode $ hash code) code + + +codeDBGet::B.ByteString->ContextM (Maybe B.ByteString) +codeDBGet key = do + ctx <- get + runResourceT $ + DB.get (codeDB ctx) def key + +stateDBPut::B.ByteString->B.ByteString->ContextM () +stateDBPut key val = do + ctx <- get + runResourceT $ + DB.put (MP.ldb $ stateDB ctx) def key val + put ctx{stateDB=(stateDB ctx){MP.stateRoot=MP.SHAPtr key}} + +stateDBGet::B.ByteString->ContextM (Maybe B.ByteString) +stateDBGet key = do + ctx <- get + runResourceT $ + DB.get (MP.ldb $ stateDB ctx) def key + + +putKeyVal::N.NibbleString->RLPObject->ContextM () +putKeyVal key val = do + ctx <- get + newStateDB <- + liftIO $ runResourceT $ MP.putKeyVal (stateDB ctx) key val + put ctx{stateDB=newStateDB} + +getKeyVals::N.NibbleString->ContextM [(N.NibbleString, RLPObject)] +getKeyVals key = do + ctx <- get + liftIO $ runResourceT $ MP.getKeyVals (stateDB ctx) key + +deleteStorageKey::N.NibbleString->ContextM () +deleteStorageKey key = do + ctx <- get + newStorageDB <- + liftIO $ runResourceT $ MP.deleteKey (storageDB ctx) key + put ctx{storageDB=newStorageDB} + +putStorageKeyVal::N.NibbleString->RLPObject->ContextM () +putStorageKeyVal key val = do + ctx <- get + newStorageDB <- + liftIO $ runResourceT $ MP.putKeyVal (storageDB ctx) key val + liftIO $ putStrLn $ "storage state root is " ++ show (pretty $ MP.stateRoot newStorageDB) + put ctx{storageDB=newStorageDB} + +getStorageKeyVals::N.NibbleString->ContextM [(N.NibbleString, RLPObject)] +getStorageKeyVals key = do + ctx <- get + liftIO $ runResourceT $ MP.getKeyVals (storageDB ctx) key diff --git a/src/Blockchain/ExtWord.hs b/src/Blockchain/ExtWord.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/ExtWord.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Blockchain.ExtWord ( + Word256 + ) where + +import Network.Haskoin.Crypto (Word256) + +import Data.Ix + +instance Ix Word256 where + range (x, y) | x == y = [x] + range (x, y) = x:range (x+1, y) + index (x, y) z | z < x || z > y = error $ "Ix{Word256}.index: Index (" ++ show z ++ ") out of range ((" ++ show x ++ "," ++ show y ++ "))" + index (x, _) z = fromIntegral $ z - x + inRange (x, y) z | z >= x && z <= y = True + inRange _ _ = False diff --git a/src/Blockchain/ExtendedECDSA.hs b/src/Blockchain/ExtendedECDSA.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/ExtendedECDSA.hs @@ -0,0 +1,91 @@ + +module Blockchain.ExtendedECDSA ( + ExtendedSignature(..), + extSignMsg, + getPubKeyFromSignature + ) where + +import Control.Monad +import qualified Control.Monad.State as S +import Control.Monad.Trans (lift) +import Data.Bits + +import Network.Haskoin.Constants +import Network.Haskoin.Crypto +import Network.Haskoin.Internals +import Network.Haskoin.Util + +--import Debug.Trace + +nextSecret :: Monad m => SecretT m FieldN +nextSecret = do + (ws,f) <- S.get + let (ws',randM) = hmacDRBGGen ws 32 (stringToBS haskoinUserAgent) + case randM of + (Just rand) -> do + S.put (ws',f) + let randI = bsToInteger rand + if isIntegerValidKey randI + then return $ fromInteger randI + else nextSecret + Nothing -> do + seed <- lift $ f 32 -- Read 256 bits to re-seed the PRNG + let ws0 = hmacDRBGRsd ws' seed (stringToBS haskoinUserAgent) + S.put (ws0,f) + nextSecret + +genKeyPair :: Monad m => SecretT m (FieldN, Point) +genKeyPair = do + -- 3.2.1.1 + d <- nextSecret + -- 3.2.1.2 + let q = mulPoint d curveG + -- 3.2.1.3 + return (d,q) + +----------------------- + +data ExtendedSignature = ExtendedSignature Signature Bool deriving (Show, Eq) + +unsafeExtSignMsg :: Word256 -> FieldN -> (FieldN, Point) -> Maybe ExtendedSignature +unsafeExtSignMsg _ 0 _ = Nothing +unsafeExtSignMsg h d (k,p) = do + -- 4.1.3.1 (4.1.3.2 not required) + (x,y) <- getAffine p + -- 4.1.3.3 + let r = fromIntegral x :: FieldN + guard (r /= 0) + -- 4.1.3.4 / 4.1.3.5 + let e = fromIntegral h :: FieldN + -- 4.1.3.6 + let s' = (e + r*d)/k + -- Canonicalize signatures: s <= order/2 + -- maxBound/2 = (maxBound+1)/2 = order/2 (because order is odd) + s = if s' > (maxBound `div` 2) then (-s') else s' + guard (s /= 0) + -- 4.1.3.7 + --return $ (Signature r s, odd y `xor` (s' > (maxBound `div` 2))) + return $ ExtendedSignature (Signature r s) (odd y `xor` (s' > (maxBound `div` 2))) + +extSignMsg :: Monad m => Word256 -> PrvKey -> SecretT m ExtendedSignature +extSignMsg _ (PrvKey 0) = error "signMsg: Invalid private key 0" +extSignMsg _ (PrvKeyU 0) = error "signMsg: Invalid private key 0" +extSignMsg h d = do + -- 4.1.3.1 + (k,p) <- genKeyPair + case unsafeExtSignMsg h (prvKeyFieldN d) (k,p) of + (Just sig) -> return sig + -- If signing failed, retry with a new nonce + Nothing -> extSignMsg h d + +------------------- + +getPubKeyFromSignature::ExtendedSignature->Word256->PubKey +getPubKeyFromSignature (ExtendedSignature sig yIsOdd) msgHash = + PubKey $ ((s / r) `mulPoint` bigR) `addPoint` ((fromIntegral curveN - fromIntegral msgHash/r) `mulPoint` curveG) + where + r = sigR sig + s = sigS sig + ys = quadraticResidue $ fromIntegral r^(3::Integer)+7 + correctY = if odd (head ys) == yIsOdd then head ys else ys !! 1 + Just bigR = makePoint (fromIntegral r) correctY diff --git a/src/Blockchain/Format.hs b/src/Blockchain/Format.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Format.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +module Blockchain.Format ( + Format(..) + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Base16 as B16 +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.ExtWord + +import Blockchain.Util + +class Format a where + format::a->String + +instance Format B.ByteString where + format x = BC.unpack (B16.encode x) + +instance Pretty Word256 where + pretty x = text $ BC.unpack (B16.encode $ B.pack $ word256ToBytes x) + diff --git a/src/Blockchain/JCommand.hs b/src/Blockchain/JCommand.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/JCommand.hs @@ -0,0 +1,145 @@ + +module Blockchain.JCommand ( + JCommand(..), + Storage(..), + Word(..), + JBool(..), + jcompile + ) where + +import Prelude hiding (LT, GT, EQ) + +import Control.Applicative +import Control.Monad + +import Blockchain.Util +import Blockchain.VM.Opcodes +import Blockchain.VM.Code + +import Blockchain.ExtWord + +data Storage = PermStorage Word | MemStorage Word deriving (Show) + +data Word = + Number Word256 | + TheAddress | + Origin | + Caller | + CallDataSize | + Input Word | + PermVal Word | + MemVal Word | + Abs Word | + Word :+: Word | Word :-: Word | Word :*: Word | Neg Word | Signum Word deriving (Show) + +data JBool = JTrue | JFalse | + Word :==: Word | + Word :>: Word | + Word :<: Word | + Word :>=: Word | + Word :<=: Word + deriving (Show) + +instance Num Word where + fromInteger x = Number $ fromInteger x + Number x + Number y = Number $ x+y + x + y = x :+: y + x - y = x :-: y + Number x * Number y = Number $ x*y + x * y = x :*: y + abs (Number x) = Number $ abs x + abs x = Abs x + negate (Number x) = Number (-x) + negate x = Neg x + + signum (Number x) = Number (signum x) + signum x = Signum x + + +data JCommand = Storage :=: Word | + If JBool [JCommand] | + While JBool [JCommand] | + ReturnCode Code deriving (Show) + +infixl 6 :+: +infixl 5 :-: +infixl 4 :=: + + +j::[JCommand]->Unique [Operation] +j x = fmap concat $ sequence $ jCommand2Op <$> x + +jcompile::[JCommand]->(Int, [Operation]) +jcompile x = runUnique (j x) 0 + +data Unique a = Unique { runUnique::Int->(Int, a) } + +instance Functor Unique where + fmap = liftM + +instance Applicative Unique where + pure = return + (<*>) = ap + +instance Monad Unique where + (Unique runner) >>= f = Unique $ \val -> let (val', x') = runner val + Unique g = f x' + in g val' + return x = Unique $ \val -> (val, x) + +getUnique::String->Unique String +getUnique s = Unique $ \val -> (val+1, s ++ show val) + +pushVal::Word->[Operation] +pushVal (Number x) = [PUSH $ integer2Bytes1 $ toInteger x] +pushVal TheAddress = [ADDRESS] +pushVal Caller = [CALLER] +pushVal CallDataSize = [CALLDATASIZE] +pushVal Origin = [ORIGIN] +pushVal (Input x) = pushVal x ++ [CALLDATALOAD] +pushVal (PermVal x) = pushVal x ++ [SLOAD] +pushVal (MemVal x) = pushVal x ++ [MLOAD] +pushVal (x :+: y) = pushVal y ++ pushVal x ++ [ADD] +pushVal (x :-: y) = pushVal y ++ pushVal x ++ [SUB] +pushVal (x :*: y) = pushVal y ++ pushVal x ++ [MUL] +pushVal (Abs x) = pushVal x ++ pushVal (Signum x) ++ [MUL] +pushVal (Signum x) = pushVal x ++ pushVal (Number 0) ++ [GT] ++ pushVal x ++ pushVal (Number 0) ++ [LT, SUB] +pushVal (Neg x) = pushVal x ++ [NEG] + +pushBoolVal::JBool->[Operation] +pushBoolVal (x :==: y) = pushVal y ++ pushVal x ++ [EQ] +pushBoolVal (x :>: y) = pushVal y ++ pushVal x ++ [GT] +pushBoolVal (x :<: y) = pushVal y ++ pushVal x ++ [LT] +pushBoolVal (x :>=: y) = pushVal y ++ pushVal x ++ [ISZERO, LT] +pushBoolVal (x :<=: y) = pushVal y ++ pushVal x ++ [ISZERO, GT] +pushBoolVal JTrue = [PUSH [1]] +pushBoolVal JFalse = [PUSH [0]] + +jCommand2Op::JCommand->Unique [Operation] +jCommand2Op (PermStorage sPosition :=: val) = + return $ pushVal val ++ pushVal sPosition ++ [SSTORE] +jCommand2Op (MemStorage sPosition :=: val) = + return $ pushVal val ++ pushVal sPosition ++ [MSTORE] +jCommand2Op (If cond code) = do + after <- getUnique "after" + compiledCode <- j code + return $ pushBoolVal cond ++ [ISZERO, PUSHLABEL after, JUMPI] ++ compiledCode ++ [LABEL after] +jCommand2Op (While cond code) = do + after <- getUnique "after" + before <- getUnique "before" + compiledCode <- j code + return $ [LABEL before] ++ pushBoolVal cond ++ [ISZERO, PUSHLABEL after, JUMPI] ++ compiledCode ++ [PUSHLABEL before, JUMP] ++ [LABEL after] +jCommand2Op (ReturnCode (Code codeBytes)) = do + codeBegin <- getUnique "begin" + codeEnd <- getUnique "end" + return $ + [ + PUSHDIFF codeBegin codeEnd, + PUSHLABEL codeBegin, + PUSH [0], + CODECOPY, + PUSHDIFF codeBegin codeEnd, + PUSH [0], + RETURN + ] + ++ [LABEL codeBegin, DATA codeBytes, LABEL codeEnd] diff --git a/src/Blockchain/PeerUrls.hs b/src/Blockchain/PeerUrls.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/PeerUrls.hs @@ -0,0 +1,146 @@ + +module Blockchain.PeerUrls where + +-- Working 0, 1, 2, 67, 119 + +ipAddresses::[(String, String)] +ipAddresses = + [ + ("127.0.0.1", "30303"), + ("207.12.89.180", "30303"), + ("24.90.136.85", "40404"), + ("185.43.109.23", "30303"), + ("76.220.27.23", "30303"), + ("194.151.205.61", "30303"), + ("104.236.44.20", "30303"), + ("90.215.69.132", "30303"), + ("46.115.170.122", "30303"), + ("82.113.99.187", "30303"), + ("54.73.114.158", "30303"), + ("94.197.120.233", "30303"), + ("99.36.164.218", "30301"), + ("79.205.230.196", "30303"), + ("213.61.84.226", "30303"), + ("82.217.72.169", "20818"), + ("66.91.18.59", "30303"), + ("92.225.49.139", "30303"), + ("46.126.19.53", "30303"), + ("209.6.197.196", "30303"), + ("95.91.196.230", "30303"), + ("77.87.49.7", "30303"), + ("77.50.138.143", "22228"), + ("84.232.211.95", "30300"), + ("213.127.159.150", "30303"), + ("89.71.42.180", "30303"), + ("216.240.30.23", "30303"), + ("62.163.114.115", "30304"), + ("178.198.11.18", "30303"), + ("94.117.148.121", "30303"), + ("80.185.182.157", "30303"), + ("129.194.71.126", "30303"), + ("129.194.71.126", "12667"), + ("199.254.238.167", "30303"), + ("71.208.244.211", "30303"), + ("46.114.45.182", "30303"), + ("178.37.149.29", "30303"), + ("81.38.156.153", "30303"), + ("5.144.60.120", "30304"), + ("67.188.113.229", "30303"), + ("23.121.237.24", "30303"), + ("37.120.31.241", "30303"), + ("79.178.55.18", "30303"), + ("50.1.116.44", "30303"), + ("213.129.230.10", "30303"), + ("91.64.116.234", "30303"), + ("86.164.51.215", "30303"), + ("46.127.142.224", "30300"), + ("195.221.66.4", "30300"), + ("95.90.239.241", "30303"), + ("176.67.169.137", "30303"), + ("94.224.199.123", "30303"), + ("38.117.159.162", "30303"), + ("5.9.141.240", "30303"), + ("110.164.236.93", "30303"), + ("86.147.58.164", "30303"), + ("188.63.78.132", "30303"), + ("128.12.255.172", "30303"), + ("90.35.135.242", "30303"), + ("82.232.60.209", "30303"), + ("87.215.30.74", "30303"), + ("129.194.81.234", "22318"), + ("178.19.221.38", "30303"), + ("94.174.162.250", "30303"), + ("193.138.219.234", "30303"), + ("188.122.16.76", "30303"), + ("71.237.182.164", "30303"), + ("207.12.89.180", "30303"), + ("207.12.89.180", "30300"), + ("84.72.161.78", "30303"), + ("173.238.50.70", "30303"), + ("90.213.167.21", "30303"), + ("120.148.4.242", "30303"), + ("67.237.187.247", "30303"), + ("77.101.50.246", "30303"), + ("88.168.242.87", "30300"), + ("40.141.47.2", "30303"), + ("109.201.154.150", "30303"), + ("5.228.251.149", "30303"), + ("79.205.244.3", "30303"), + ("77.129.6.180", "30303"), + ("208.52.154.136", "30300"), + ("199.254.238.167", "30303"), + ("80.185.170.70", "30303"), + ("188.220.9.241", "30303"), + ("129.194.81.234", "30303"), + ("76.100.20.104", "30300"), + ("162.210.197.234", "30303"), + ("89.246.69.218", "30303"), + ("178.19.221.38", "29341"), + ("217.91.252.61", "30303"), + ("118.241.70.83", "30303"), + ("190.17.13.160", "30303"), + ("68.7.46.39", "30303"), + ("99.36.164.218", "30301"), + ("37.157.38.10", "30303"), + ("24.176.161.133", "30303"), + ("82.113.99.187", "30303"), + ("194.151.205.61", "30303"), + ("54.235.157.173", "30303"), + ("95.91.210.151", "10101"), + ("108.59.8.182", "30303"), + ("217.247.70.175", "30303"), + ("173.238.52.23", "30303"), + ("82.217.72.169", "30304"), + ("176.114.249.240", "30303"), + ("178.19.221.38", "10101"), + ("87.149.174.176", "990"), + ("95.90.239.67", "30300"), + ("77.129.3.69", "30303"), + ("88.116.98.234", "30303"), + ("216.164.146.72", "22880"), + ("107.170.255.207", "30303"), + ("178.62.221.246", "30303"), + ("177.205.165.56", "30303"), + ("115.188.14.179", "112"), + ("145.129.59.101", "30303"), + ("64.134.53.142", "30303"), + ("68.142.28.137", "30303"), + ("162.243.131.173", "30303"), + ("81.181.146.231", "30303"), + ("23.22.211.45", "30303"), + ("24.134.75.192", "30303"), + ("188.63.251.204", "30303"), + ("93.159.121.155", "30303"), + ("109.20.132.214", "30303"), + ("204.50.102.246", "30303"), + ("50.245.145.217", "30303"), + ("86.143.179.69", "30303"), + ("77.50.138.143", "22228"), + ("23.22.211.45", "992"), + ("65.206.95.146", "30303"), + ("68.60.166.58", "30303"), + ("178.198.215.3", "30303"), + ("64.134.58.80", "30303"), + ("207.229.173.166", "30303") + ] + diff --git a/src/Blockchain/SHA.hs b/src/Blockchain/SHA.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/SHA.hs @@ -0,0 +1,59 @@ + +module Blockchain.SHA ( + SHA(..), + hash, + rlp2Word512, + word5122RLP, + padZeros, + sha2SHAPtr + ) where + +import Control.Monad +import qualified Crypto.Hash.SHA3 as C +import Data.Binary +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +import Network.Haskoin.Internals +import Numeric +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Data.RLP +import Blockchain.Database.MerklePatricia +import Blockchain.Util + +newtype SHA = SHA Word256 deriving (Show, Eq) + +instance Pretty SHA where + pretty (SHA x) = yellow $ text $ padZeros 64 $ showHex x "" + +instance Binary SHA where + put (SHA x) = sequence_ $ fmap put $ word256ToBytes $ fromIntegral x + get = do + bytes <- replicateM 32 get + let byteString = B.pack bytes + return (SHA $ fromInteger $ byteString2Integer byteString) + +instance RLPSerializable SHA where + rlpDecode (RLPString s) | length s == 32 = SHA $ decode $ BLC.pack s + rlpDecode (RLPScalar 0) = SHA 0 --special case seems to be allowed, even if length of zeros is wrong + rlpDecode x = error ("Missing case in rlpDecode for SHA: " ++ show x) + --rlpEncode (SHA 0) = RLPNumber 0 + rlpEncode (SHA val) = RLPString $ BC.unpack $ fst $ B16.decode $ BC.pack $ padZeros 64 $ showHex val "" + +sha2SHAPtr::SHA->SHAPtr +sha2SHAPtr (SHA x) = SHAPtr $ B.pack $ word256ToBytes x + +hash::BC.ByteString->SHA +hash = SHA . fromIntegral . byteString2Integer . C.hash 256 + +--------------------- Word512 stuff + +rlp2Word512::RLPObject->Word512 +rlp2Word512 (RLPString s) | length s == 64 = decode $ BLC.pack s +rlp2Word512 x = error ("Missing case in rlp2Word512: " ++ show x) + +word5122RLP::Word512->RLPObject +word5122RLP val = RLPString $ BLC.unpack $ encode val + diff --git a/src/Blockchain/SampleTransactions.hs b/src/Blockchain/SampleTransactions.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/SampleTransactions.hs @@ -0,0 +1,609 @@ + +module Blockchain.SampleTransactions where + +import Prelude hiding (EQ) + +import qualified Data.ByteString as B + +import Blockchain.Data.Address +import Blockchain.Data.Transaction +import Blockchain.Constants +import Blockchain.JCommand +import Blockchain.Util +import Blockchain.VM.Code +import Blockchain.VM.Labels +import Blockchain.VM.Opcodes + +--import Debug.Trace + +createContract::Integer->Integer->Code->Transaction +createContract val gl code = ContractCreationTX { + tNonce = 0, + gasPrice = 0x9184e72a000, + tGasLimit = gl, + value = val, + tInit = code + } + +createMessage::Integer->Integer->Address->B.ByteString->Transaction +createMessage val gl toAddr theData = MessageTX { + tNonce = 0, + gasPrice = 0x9184e72a000, + tGasLimit = gl, + to = toAddr, + value = val, + tData = theData + } + +---------------------- + +simpleTX::Transaction +simpleTX = + createContract 0 550 + $ compile + [ + PUSH [2], + PUSH [0], + MSTORE, + PUSH [0x20], + PUSH [0], + RETURN + ] + +outOfGasTX::Transaction +outOfGasTX = + createContract 3 522 + $ compile + [ + PUSH [1], + PUSH [0], + MSTORE + ] + +simpleStorageTX::Transaction +simpleStorageTX = + createContract 3 1000 + $ compile + [ + PUSH [1], + PUSH [0], + SSTORE + ] + +createInit::[JCommand]->[JCommand]->Code +createInit initFunc contract = -- trace (intercalate "-" $ show <$> contract) $ +-- trace (intercalate "\n " $ fmap show $ snd $ jcompile $ initFunc ++ [ReturnCode contract]) $ do + compile $ lcompile $ snd $ jcompile $ initFunc ++ [ReturnCode $ compile $ lcompile $ snd $ jcompile contract] + +createContractTX::Transaction +createContractTX = + createContract (1000*finney) 1000 + $ createInit [] + [ + PermStorage (Number 0) :=: Input 0 + ] + +sendMessageTX::Transaction +sendMessageTX = + createMessage (1000*finney) 1000 (Address 0x9f840fe058ce3d84e319b8c747accc1e52f69426) + (B.pack $ word256ToBytes 0x1234) + + + +paymentContract::Transaction +paymentContract = + createContract (1000*finney) 2000 + $ createInit + [ + PermStorage Caller :=: Number 1000 + ] + ( + let + toAddr = Input (0*32) + fromAddr = Caller + val = Input (1*32) + in + [ + If (PermVal fromAddr :>=: val) + [ + PermStorage fromAddr :=: PermVal fromAddr - val, + PermStorage toAddr :=: PermVal toAddr + val + ] + + ] + ) + +sendCoinTX::Transaction +sendCoinTX = + createMessage 0 2000 (Address 0x9f840fe058ce3d84e319b8c747accc1e52f69426) + (B.pack $ word256ToBytes 0x1 ++ word256ToBytes 500) + + + + +keyValuePublisher::Transaction +keyValuePublisher = + createContract (1000*finney) 2000 + $ createInit + [ + PermStorage 69 :=: Caller + ] + ( + let + inputP = MemStorage (Number 0) + inputPr = MemVal (Number 0) + in + [ + If (Caller :==: PermVal (Number 69)) + [ + While (inputPr :<: CallDataSize) + [ + PermStorage (Input inputPr) :=: Input (inputPr + 32), + inputP :=: inputPr + 64 + ] + ] + + ] + ) + + +sendKeyVal::Transaction +sendKeyVal = + createMessage 0 2000 (Address 0x9f840fe058ce3d84e319b8c747accc1e52f69426) + (B.pack $ word256ToBytes 1000 ++ word256ToBytes 2000 ++ word256ToBytes 1234 ++ word256ToBytes 1) + + + +{- + + (when (= (caller) @@69) + (for {} (< @i (calldatasize)) [i](+ @i 64) + [[ (calldataload @i) ]] (calldataload (+ @i 32)) + ) +-} + + + +mysteryCode::[Operation] +mysteryCode = + [ + PUSH [3,144], + DUP1, + PUSH [0,14], + PUSH [0], + CODECOPY, + PUSH [3,158], + JUMP, + PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + PUSH [32], + MSTORE, + PUSH [0], + PUSH [64], + MSTORE, + PUSH [1], + PUSH [96], + MSTORE, + PUSH [2], + PUSH [128], + MSTORE, + PUSH [3], + PUSH [160], + MSTORE, + PUSH [0], + PUSH [192], + MSTORE, + PUSH [1], + PUSH [224], + MSTORE, + PUSH [2], + PUSH [1,0], + MSTORE, + PUSH [0], + PUSH [1,32], + MSTORE, + PUSH [1], + PUSH [1,64], + MSTORE, + PUSH [2], + PUSH [1,96], + MSTORE, + PUSH [3], + PUSH [1,128], + MSTORE, + PUSH [3], + PUSH [1,160], + MSTORE, + PUSH [32], + CALLDATASIZE, + DIV, + PUSH [1,192], + MSTORE, + PUSH [1,160], + MLOAD, + PUSH [1,128], + MLOAD, + ADD, + PUSH [1,192], + MLOAD, + SLT, + ISZERO, + PUSH [0,136], + JUMPI, + PUSH [1,64], + MLOAD, + PUSH [1,224], + MSTORE, + PUSH [32], + PUSH [1,224], + CALLCODE, + JUMPDEST, + PUSH [0], + PUSH [1,128], + MLOAD, + PUSH [1,160], + MLOAD, + PUSH [1,192], + MLOAD, + SUB, + SMOD, + EQ, + ISZERO, + ISZERO, + PUSH [0,174], + JUMPI, + PUSH [1,64], + MLOAD, + PUSH [2,0], + MSTORE, + PUSH [32], + PUSH [2,0], + CALLCODE, + JUMPDEST, + PUSH [1,128], + MLOAD, + PUSH [1,160], + MLOAD, + PUSH [1,192], + MLOAD, + SUB, + SDIV, + PUSH [2,32], + MSTORE, + PUSH [0], + PUSH [2,64], + MSTORE, + PUSH [2], + PUSH [1,160], + MLOAD, + ADD, + PUSH [32], + MUL, + CALLDATALOAD, + PUSH [2,96], + MSTORE, + PUSH [0], + PUSH [2,128], + MSTORE, + JUMPDEST, + PUSH [2,32], + MLOAD, + PUSH [2,64], + MLOAD, + SLT, + ISZERO, + PUSH [1,155], + JUMPI, + PUSH [1], + PUSH [1,160], + MLOAD, + PUSH [1,128], + MLOAD, + PUSH [2,64], + MLOAD, + MUL, + ADD, + ADD, + PUSH [32], + MUL, + CALLDATALOAD, + PUSH [2,160], + MSTORE, + PUSH [2], + PUSH [1,160], + MLOAD, + PUSH [1,128], + MLOAD, + PUSH [2,64], + MLOAD, + MUL, + ADD, + ADD, + PUSH [32], + MUL, + CALLDATALOAD, + PUSH [2,192], + MSTORE, + PUSH [2,96], + MLOAD, + PUSH [2,192], + MLOAD, + EQ, + ISZERO, + ISZERO, + PUSH [1,80], + JUMPI, + PUSH [2,192], + MLOAD, + PUSH [2,96], + MSTORE, + PUSH [0], + PUSH [2,128], + MLOAD, + EQ, + ISZERO, + ISZERO, + PUSH [1,79], + JUMPI, + PUSH [1,96], + MLOAD, + PUSH [2,224], + MSTORE, + PUSH [32], + PUSH [2,224], + CALLCODE, + JUMPDEST, + JUMPDEST, + PUSH [2,160], + MLOAD, + PUSH [2,128], + MLOAD, + ADD, + PUSH [2,128], + MSTORE, + PUSH [1], + PUSH [2,32], + MLOAD, + SUB, + PUSH [2,64], + MLOAD, + EQ, + ISZERO, + PUSH [1,139], + JUMPI, + PUSH [0], + PUSH [2,128], + MLOAD, + EQ, + ISZERO, + ISZERO, + PUSH [1,138], + JUMPI, + PUSH [1,96], + MLOAD, + PUSH [3,0], + MSTORE, + PUSH [32], + PUSH [3,0], + CALLCODE, + JUMPDEST, + JUMPDEST, + PUSH [1], + PUSH [2,64], + MLOAD, + ADD, + PUSH [2,64], + MSTORE, + PUSH [0,220], + JUMP, + JUMPDEST, + PUSH [32], + MLOAD, + SLOAD, + PUSH [3,32], + MSTORE, + PUSH [1], + PUSH [32], + MLOAD, + SLOAD, + ADD, + PUSH [32], + MLOAD, + SSTORE, + PUSH [32], + CALLDATALOAD, + PUSH [3,64], + MSTORE, + PUSH [64], + CALLDATALOAD, + PUSH [3,96], + MSTORE, + PUSH [255,255,255,255,255,255,255,255], + PUSH [3,128], + MSTORE, + PUSH [3,64], + MLOAD, + PUSH [64], + MLOAD, + PUSH [1,0,0,0,0,0,0,0,0], + PUSH [3,128], + MLOAD, + MUL, + PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + PUSH [3,32], + MLOAD, + MUL, + ADD, + ADD, + SSTORE, + PUSH [3,96], + MLOAD, + PUSH [96], + MLOAD, + PUSH [1,0,0,0,0,0,0,0,0], + PUSH [3,128], + MLOAD, + MUL, + PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + PUSH [3,32], + MLOAD, + MUL, + ADD, + ADD, + SSTORE, + NUMBER, + PUSH [128], + MLOAD, + PUSH [1,0,0,0,0,0,0,0,0], + PUSH [3,128], + MLOAD, + MUL, + PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + PUSH [3,32], + MLOAD, + MUL, + ADD, + ADD, + SSTORE, + TIMESTAMP, + PUSH [160], + MLOAD, + PUSH [1,0,0,0,0,0,0,0,0], + PUSH [3,128], + MLOAD, + MUL, + PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + PUSH [3,32], + MLOAD, + MUL, + ADD, + ADD, + SSTORE, + PUSH [0], + PUSH [2,64], + MSTORE, + JUMPDEST, + PUSH [2,32], + MLOAD, + PUSH [2,64], + MLOAD, + SLT, + ISZERO, + PUSH [3,129], + JUMPI, + PUSH [1,160], + MLOAD, + PUSH [1,128], + MLOAD, + PUSH [2,64], + MLOAD, + MUL, + ADD, + PUSH [32], + MUL, + CALLDATALOAD, + PUSH [3,160], + MSTORE, + PUSH [1], + PUSH [1,160], + MLOAD, + PUSH [1,128], + MLOAD, + PUSH [2,64], + MLOAD, + MUL, + ADD, + ADD, + PUSH [32], + MUL, + CALLDATALOAD, + PUSH [2,160], + MSTORE, + PUSH [2], + PUSH [1,160], + MLOAD, + PUSH [1,128], + MLOAD, + PUSH [2,64], + MLOAD, + MUL, + ADD, + ADD, + PUSH [32], + MUL, + CALLDATALOAD, + PUSH [2,192], + MSTORE, + PUSH [3,160], + MLOAD, + PUSH [192], + MLOAD, + PUSH [1,0,0,0,0,0,0,0,0], + PUSH [2,64], + MLOAD, + MUL, + PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + PUSH [3,32], + MLOAD, + MUL, + ADD, + ADD, + SSTORE, + PUSH [2,160], + MLOAD, + PUSH [224], + MLOAD, + PUSH [1,0,0,0,0,0,0,0,0], + PUSH [2,64], + MLOAD, + MUL, + PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + PUSH [3,32], + MLOAD, + MUL, + ADD, + ADD, + SSTORE, + PUSH [2,192], + MLOAD, + PUSH [1,0], + MLOAD, + PUSH [1,0,0,0,0,0,0,0,0], + PUSH [2,64], + MLOAD, + MUL, + PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + PUSH [3,32], + MLOAD, + MUL, + ADD, + ADD, + SSTORE, + PUSH [1], + PUSH [2,64], + MLOAD, + ADD, + PUSH [2,64], + MSTORE, + PUSH [2,138], + JUMP, + JUMPDEST, + PUSH [1,32], + MLOAD, + PUSH [3,192], + MSTORE, + PUSH [32], + PUSH [3,192], + CALLCODE, + JUMPDEST, + PUSH [0], + CALLCODE + ] + +createMysteryContract::Transaction +createMysteryContract = ContractCreationTX { + tNonce = 0, + gasPrice = 0x9184e72a000, + tGasLimit = 8000, + value = 0, + tInit = compile mysteryCode + } diff --git a/src/Blockchain/Util.hs b/src/Blockchain/Util.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/Util.hs @@ -0,0 +1,51 @@ + +module Blockchain.Util ( + byteString2Integer, + bytes2Integer, + integer2Bytes, + integer2Bytes1, + word160ToBytes, + word256ToBytes, + padZeros, + tab + ) where + +import Data.Bits +import qualified Data.ByteString as B +import Data.Word +import Network.Haskoin.Crypto (Word160, Word256) + +--I hate this, it is an ugly way to create an Integer from its component bytes. +--There should be an easier way.... +--See http://stackoverflow.com/questions/25854311/efficient-packing-bytes-into-integers +byteString2Integer::B.ByteString->Integer +byteString2Integer x = bytes2Integer $ B.unpack x + +bytes2Integer::[Word8]->Integer +bytes2Integer [] = 0 +bytes2Integer (byte:rest) = fromIntegral byte `shift` (8 * length rest) + bytes2Integer rest + +integer2Bytes::Integer->[Word8] +integer2Bytes 0 = [] +integer2Bytes x = integer2Bytes (x `shiftR` 8) ++ [fromInteger (x .&. 255)] + +--integer2Bytes1 is integer2Bytes, but with the extra condition that the output be of length 1 or more. +integer2Bytes1::Integer->[Word8] +integer2Bytes1 0 = [0] +integer2Bytes1 x = integer2Bytes x + +word256ToBytes::Word256->[Word8] +word256ToBytes x = + map (\byte -> fromIntegral $ (x `shiftR` (byte*8)) .&. 0xFF) [31,30..0] + +word160ToBytes::Word160->[Word8] +word160ToBytes x = + map (\byte -> fromIntegral $ (x `shiftR` (byte*8)) .&. 0xFF) [19,18..0] + +padZeros::Int->String->String +padZeros n s = replicate (n - length s) '0' ++ s + +tab::String->String +tab [] = [] +tab ('\n':rest) = '\n':' ':' ':' ':' ':tab rest +tab (c:rest) = c:tab rest diff --git a/src/Blockchain/VM.hs b/src/Blockchain/VM.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/VM.hs @@ -0,0 +1,529 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Blockchain.VM ( + runCodeFromStart + ) where + +import Prelude hiding (LT, GT, EQ) + +import Control.Monad.IO.Class +import Data.Bits +import qualified Data.ByteString as B +import Data.Char +import Data.Function +import Data.Functor +import Data.Maybe +import Data.Time.Clock.POSIX +import Network.Haskoin.Crypto (Word256) +import Numeric +--import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Context +import qualified Blockchain.Colors as CL +import Blockchain.Data.Address +import Blockchain.Data.AddressState +import Blockchain.Data.Block +import qualified Data.NibbleString as N +import Blockchain.Data.RLP +import Blockchain.DB.CodeDB +import Blockchain.DB.ModifyStateDB +import Blockchain.ExtDBs +import Blockchain.SHA +import Blockchain.Util +import Blockchain.VM.Code +import Blockchain.VM.Environment +import Blockchain.VM.Memory +import Blockchain.VM.Opcodes +import Blockchain.VM.VMState + +--import Debug.Trace + +bool2Word256::Bool->Word256 +bool2Word256 True = 1 +bool2Word256 False = 0 + +word2562Bool::Word256->Bool +word2562Bool 1 = True +word2562Bool _ = False + +binaryAction::(Word256->Word256->Word256)->Environment->VMState->ContextM VMState +binaryAction action _ state@VMState{stack=x:y:rest} = return state{stack=x `action` y:rest} +binaryAction _ _ state = return state{vmException=Just StackTooSmallException} + +unaryAction::(Word256->Word256)->Environment->VMState->ContextM VMState +unaryAction action _ state@VMState{stack=x:rest} = return state{stack=action x:rest} +unaryAction _ _ state = return state{vmException=Just StackTooSmallException} + + +s256ToInteger::Word256->Integer +s256ToInteger i | i < 0x7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF = toInteger i +s256ToInteger i = 0x10000000000000000000000000000000000000000000000000000000000000000 - toInteger i + + +swapn::Int->VMState->ContextM VMState +swapn n state@VMState{stack=v1:rest1} | length rest1 > n = return state{stack=v2:(middle++(v1:rest2))} + where + (middle, v2:rest2) = splitAt (n-1) rest1 +swapn _ _ = error "swapn called with not enough elements in the stack" + + +--TODO- This really should be in its own monad! +--The monad should manage everything in the VM and environment (extending the ContextM), and have pop and push operations, perhaps even automating pc incrementing, gas charges, etc. +--The code would simplify greatly, but I don't feel motivated to make the change now since things work. + +runOperation::Operation->Environment->VMState->ContextM VMState +runOperation STOP _ state = return state{done=True} + +runOperation ADD env state = binaryAction (+) env state +runOperation MUL env state = binaryAction (*) env state +runOperation SUB env state = binaryAction (-) env state +runOperation DIV env state = binaryAction quot env state +runOperation SDIV env state = binaryAction ((fromIntegral .) . quot `on` s256ToInteger) env state +runOperation MOD env state = binaryAction mod env state +runOperation SMOD env state = binaryAction ((fromIntegral .) . mod `on` s256ToInteger) env state +runOperation ADDMOD env state = binaryAction ((fromIntegral .) . (+) `on` s256ToInteger) env state +runOperation EXP env state = binaryAction (^) env state +runOperation NEG env state = unaryAction negate env state +runOperation LT env state = binaryAction ((bool2Word256 .) . (<)) env state +runOperation GT env state = binaryAction ((bool2Word256 .) . (>)) env state +runOperation SLT env state = binaryAction ((bool2Word256 .) . ((<) `on` s256ToInteger)) env state +runOperation SGT env state = binaryAction ((bool2Word256 .) . ((>) `on` s256ToInteger)) env state +runOperation EQ env state = binaryAction ((bool2Word256 .) . (==)) env state +runOperation ISZERO env state = unaryAction (bool2Word256 . (==0)) env state +runOperation AND env state = binaryAction (.&.) env state +runOperation OR env state = binaryAction (.|.) env state +runOperation XOR env state = binaryAction xor env state + +runOperation BYTE env state = binaryAction (\x y -> y `shiftR` (8*(31 - fromIntegral x)) .&. 0xFF) env state + +runOperation SHA3 _ state@VMState{stack=(p:size:rest)} = do + SHA theHash <- fmap hash $ liftIO $ mLoadByteString state p size + return state{stack=theHash:rest} + +runOperation ADDRESS Environment{envOwner=Address a} state = return state{stack=fromIntegral a:stack state} + +runOperation BALANCE _ state@VMState{stack=(x:rest)} = do + addressState <- getAddressState (Address $ fromIntegral x) + return state{stack=fromIntegral (balance addressState):rest} +runOperation BALANCE env state = liftIO $ addErr "stack did not contain enough elements" (envCode env) state + +runOperation ORIGIN Environment{envSender=Address sender} state = return state{stack=fromIntegral sender:stack state} + +runOperation CALLER Environment{envSender=Address owner} state = return state{stack=fromIntegral owner:stack state} + +runOperation CALLVALUE Environment{envValue=val} state = return state{stack=fromIntegral val:stack state} + +runOperation CALLDATALOAD Environment{envInputData=d} state@VMState{stack=p:rest} = do + let val = bytes2Integer $ appendZerosTo32 $ B.unpack $ B.take 32 $ B.drop (fromIntegral p) d + return state{stack=fromIntegral val:rest} + where + appendZerosTo32 x | length x < 32 = x ++ replicate (32-length x) 0 + appendZerosTo32 x = x + +runOperation CALLDATALOAD _ s = return s{ vmException=Just StackTooSmallException } + +runOperation CALLDATASIZE Environment{envInputData=d} state = return state{stack=fromIntegral (B.length d):stack state} + +runOperation CALLDATACOPY Environment{envInputData=d} state@VMState{stack=memP:codeP:size:rest} = do + state'<-liftIO $ mStoreByteString state memP $ B.take (fromIntegral size) $ B.drop (fromIntegral codeP) d + return state'{stack=rest} + +runOperation CODESIZE Environment{envCode=c} state = return state{stack=fromIntegral (codeLength c):stack state} + +runOperation CODECOPY Environment{envCode=Code c} state@VMState{stack=memP:codeP:size:rest} = do + state' <- liftIO $ mStoreByteString state memP $ B.take (fromIntegral size) $ B.drop (fromIntegral codeP) c + return state'{stack=rest} + +runOperation GASPRICE Environment{envGasPrice=gp} state = return state{stack=fromIntegral gp:stack state} + +runOperation PREVHASH Environment{envBlock=Block{blockData=BlockData{parentHash=SHA prevHash}}} state = return state{stack=prevHash:stack state} + +runOperation COINBASE Environment{envBlock=Block{blockData=BlockData{coinbase=Address cb}}} state = return state{stack=fromIntegral cb:stack state} + +runOperation TIMESTAMP Environment{envBlock=Block{blockData=bd}} state = return state{stack=round (utcTimeToPOSIXSeconds $ timestamp bd):stack state} +runOperation NUMBER Environment{envBlock=Block{blockData=bd}} state = return state{stack=fromIntegral (number bd):stack state} +runOperation DIFFICULTY Environment{envBlock=Block{blockData=bd}} state = return state{stack=fromIntegral (difficulty bd):stack state} +runOperation GASLIMIT Environment{envBlock=Block{blockData=bd}} state = return state{stack=fromIntegral (gasLimit bd):stack state} + +runOperation POP _ state@VMState{stack=_:rest} = return state{stack=rest} +runOperation POP env state = liftIO $ addErr "Stack did not contain any items" (envCode env) state + +runOperation LOG0 _ state@VMState{stack=_:_:rest} = return state{stack=rest} +runOperation LOG1 _ state@VMState{stack=_:_:_:rest} = return state{stack=rest} +runOperation LOG2 _ state@VMState{stack=_:_:_:_:rest} = return state{stack=rest} +runOperation LOG3 _ state@VMState{stack=_:_:_:_:_:rest} = return state{stack=rest} +runOperation LOG4 _ state@VMState{stack=_:_:_:_:_:_:rest} = return state{stack=rest} + +runOperation MLOAD _ state@VMState{stack=(p:rest)} = do + bytes <- liftIO $ mLoad state p + return $ state { stack=fromInteger (bytes2Integer bytes):rest } + +runOperation MSTORE _ state@VMState{stack=(p:val:rest)} = do + state' <- liftIO $ mStore state p val + return state'{stack=rest} + +runOperation MSTORE8 _ state@VMState{stack=(p:val:rest)} = do + state' <- liftIO $ mStore8 state (fromIntegral p) (fromIntegral $ val .&. 0xFF) + return state'{stack=rest} + +runOperation SLOAD _ state@VMState{stack=(p:rest)} = do + vals <- getStorageKeyVals (N.pack $ (N.byte2Nibbles =<<) $ word256ToBytes p) + let val = case vals of + [] -> 0 + [x] -> fromInteger $ rlpDecode $ rlpDeserialize $ rlpDecode $ snd x + _ -> error "Multiple values in storage" + + return $ state { stack=val:rest } + +runOperation SSTORE _ state@VMState{stack=(p:val:rest)} = do + if val == 0 + then deleteStorageKey (N.pack $ (N.byte2Nibbles =<<) $ word256ToBytes p) + else putStorageKeyVal (N.pack $ (N.byte2Nibbles =<<) $ word256ToBytes p) (rlpEncode $ rlpSerialize $ rlpEncode $ toInteger val) + return $ state { stack=rest } +runOperation SSTORE _ state = + return $ state { vmException=Just StackTooSmallException } + +--TODO- refactor so that I don't have to use this -1 hack +runOperation JUMP _ state@VMState{stack=(p:rest)} = + return $ state { stack=rest, pc=fromIntegral p - 1} -- Subtracting 1 to compensate for the pc-increment that occurs every step. + +runOperation JUMPI _ state@VMState{stack=(p:cond:rest)} = + return $ state { stack=rest, pc=if word2562Bool cond then fromIntegral p - 1 else pc state } + +runOperation PC _ state = + return state{stack=fromIntegral (pc state):stack state} + +runOperation MSIZE _ state@VMState{memory=m} = do + memSize <- liftIO $ getSizeInBytes m + return state{stack=memSize:stack state} + +runOperation GAS _ state = + return $ state { stack=fromInteger (vmGasRemaining state):stack state } + +runOperation JUMPDEST _ state = return state + +runOperation (PUSH vals) _ state = + return $ + state { stack=fromIntegral (bytes2Integer vals):stack state } + + + +-- | SUICIDE deriving (Show, Eq, Ord) + +runOperation DUP1 _ state@VMState{stack=s@(v:_)} = return state{stack=v:s} +runOperation DUP2 _ state@VMState{stack=s@(_:v:_)} = return state{stack=v:s} +runOperation DUP3 _ state@VMState{stack=s@(_:_:v:_)} = return state{stack=v:s} +runOperation DUP4 _ state@VMState{stack=s@(_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP5 _ state@VMState{stack=s@(_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP6 _ state@VMState{stack=s@(_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP7 _ state@VMState{stack=s@(_:_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP8 _ state@VMState{stack=s@(_:_:_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP9 _ state@VMState{stack=s@(_:_:_:_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP10 _ state@VMState{stack=s@(_:_:_:_:_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP11 _ state@VMState{stack=s@(_:_:_:_:_:_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP12 _ state@VMState{stack=s@(_:_:_:_:_:_:_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP13 _ state@VMState{stack=s@(_:_:_:_:_:_:_:_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP14 _ state@VMState{stack=s@(_:_:_:_:_:_:_:_:_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP15 _ state@VMState{stack=s@(_:_:_:_:_:_:_:_:_:_:_:_:_:_:v:_)} = return state{stack=v:s} +runOperation DUP16 _ state@VMState{stack=s@(_:_:_:_:_:_:_:_:_:_:_:_:_:_:_:v:_)} = return state{stack=v:s} + +runOperation SWAP1 _ state = swapn 1 state +runOperation SWAP2 _ state = swapn 2 state +runOperation SWAP3 _ state = swapn 3 state +runOperation SWAP4 _ state = swapn 4 state +runOperation SWAP5 _ state = swapn 5 state +runOperation SWAP6 _ state = swapn 6 state +runOperation SWAP7 _ state = swapn 7 state +runOperation SWAP8 _ state = swapn 8 state +runOperation SWAP9 _ state = swapn 9 state +runOperation SWAP10 _ state = swapn 10 state +runOperation SWAP11 _ state = swapn 11 state +runOperation SWAP12 _ state = swapn 12 state +runOperation SWAP13 _ state = swapn 13 state +runOperation SWAP14 _ state = swapn 14 state +runOperation SWAP15 _ state = swapn 15 state +runOperation SWAP16 _ state = swapn 16 state + + + +runOperation CREATE env state@VMState{stack=value:input:size:rest} = do + addressState <- getAddressState $ envOwner env + let newAddress = getNewAddress (envOwner env) (addressStateNonce addressState) + putAddressState (envOwner env) addressState{addressStateNonce=addressStateNonce addressState + 1} + + codeBytes <- liftIO $ mLoadByteString state input size + + liftIO $ putStrLn $ "qqqqqqqqqqqqqqqqqqq:" ++ show (B.length codeBytes) + + addCode codeBytes + + putAddressState newAddress + blankAddressState + { + codeHash=hash codeBytes + } + + (state', retValue) <- nestedRun env state{stack=rest} (fromIntegral $ vmGasRemaining state) newAddress value B.empty + + case retValue of + Just bytes -> do + addCode bytes + addressState' <- getAddressState newAddress + putAddressState newAddress addressState'{codeHash=hash bytes} + _ -> return () + + return state' + +runOperation CALL env state@VMState{stack=(gas:to:value:inOffset:inSize:outOffset:_:rest)} = do + + inputData <- liftIO $ mLoadByteString state inOffset inSize + + (state', retValue) <- nestedRun env state{stack=rest} gas (Address $ fromIntegral to) value inputData + + case retValue of + Just bytes -> liftIO $ mStoreByteString state' outOffset bytes + _ -> return state' + +runOperation CALLCODE env state@VMState{stack=gas:to:value:inOffset:inSize:outOffset:_:rest} = do + + inputData <- liftIO $ mLoadByteString state inOffset inSize + let address = Address $ fromIntegral to + addressState <- getAddressState address + code <- + fromMaybe B.empty <$> + getCode (codeHash addressState) + + (nestedState, newStorageStateRoot) <- + runCodeFromStart (envOwner env) (callDepth state + 1) + (fromIntegral gas) + Environment { + envOwner = address, + envOrigin = envOrigin env, + envGasPrice = envGasPrice env, + envInputData = inputData, + envSender = envOwner env, + envValue = fromIntegral value, + envCode = Code code, + envBlock = envBlock env + } + + let retVal = fromMaybe B.empty $ returnVal nestedState + + let usedGas = fromIntegral gas - vmGasRemaining nestedState + + state' <- liftIO $ mStoreByteString state outOffset retVal + + let success = 1 + + addressState' <- getAddressState address + putAddressState address addressState'{contractRoot=newStorageStateRoot} + + pay (envOwner env) address (fromIntegral value) + + return state'{stack=success:rest, vmGasRemaining = vmGasRemaining state' - usedGas} + + + +runOperation CALLCODE _ state = + return $ state { vmException=Just StackTooSmallException } + + + +runOperation RETURN _ state@VMState{stack=(address:size:rest)} = do + retVal <- liftIO $ mLoadByteString state address size + return $ state { stack=rest, done=True, returnVal=Just retVal } + +runOperation RETURN _ state = + return $ state { vmException=Just StackTooSmallException } + +runOperation SUICIDE _ state = + return $ state { done=True, markedForSuicide=True } + + +runOperation (MalformedOpcode opcode) _ state = do + liftIO $ putStrLn $ CL.red ("Malformed Opcode: " ++ showHex opcode "") + return state { vmException=Just MalformedOpcodeException } + +runOperation x _ _ = error $ "Missing case in runOperation: " ++ show x + + + +------------------- + + + + +movePC::VMState->Int->VMState +movePC state l = state{ pc=pc state + l } + +opGasPrice::VMState->Operation->ContextM (Integer, Integer) +opGasPrice _ STOP = return (0, 0) +opGasPrice _ SUICIDE = return (0, 0) + + +opGasPrice _ BALANCE = return (20, 0) +opGasPrice _ SLOAD = return (20, 0) +opGasPrice _ CALL = return (20, 0) + +opGasPrice _ LOG0 = return (96, 0) +opGasPrice _ LOG1 = return (96, 0) +opGasPrice _ LOG2 = return (96, 0) +opGasPrice _ LOG3 = return (128, 0) +opGasPrice _ LOG4 = return (128, 0) + +opGasPrice _ CREATE = return (100, 0) + +opGasPrice VMState{stack=_:size:_} SHA3 = return (10+10*ceiling(fromIntegral size/(32::Double)), 0) + +opGasPrice VMState{stack=_:e:_} EXP = return (1 + ceiling (log (fromIntegral e) / log (256::Double)), 0) + +opGasPrice VMState{stack=_:_:size:_} CODECOPY = return (1 + ceiling (fromIntegral size / (32::Double)), 0) +opGasPrice VMState{stack=_:_:size:_} CALLDATACOPY = return (1 + ceiling (fromIntegral size / (32::Double)), 0) +opGasPrice VMState{ stack=p:val:_ } SSTORE = do + oldVals <- getStorageKeyVals (N.pack $ (N.byte2Nibbles =<<) $ word256ToBytes p) + let oldVal = + case oldVals of + [] -> 0::Word256 + [x] -> fromInteger $ rlpDecode $ snd x + _ -> error "multiple values in storage" + return $ + case (oldVal, val) of + (0, x) | x /= 0 -> (300, 0) + (x, 0) | x /= 0 -> (0, 100) + _ -> (100, 0) +opGasPrice _ _ = return (1, 0) + +--missing stuff +--Glog 1 Partial payment for a LOG operation. +--Glogdata 1 Paid for each byte in a LOG operation’s data. +--Glogtopic 1 Paid for each topic of a LOG operation. + + + + + + + + + +decreaseGas::Integer->VMState->VMState +decreaseGas val state = do + if val <= vmGasRemaining state + then state{ vmGasRemaining = vmGasRemaining state - val } + else state{ vmGasRemaining = 0, vmException = Just OutOfGasException } + +decreaseGasForOp::Operation->VMState->ContextM VMState +decreaseGasForOp op state = do + (val, theRefund) <- opGasPrice state op + return $ addToRefund theRefund $ decreaseGas val state + where + addToRefund::Integer->VMState->VMState + addToRefund val state' = state'{refund=refund state' + val} + +nibbleString2ByteString::N.NibbleString->B.ByteString +nibbleString2ByteString (N.EvenNibbleString s) = s +nibbleString2ByteString (N.OddNibbleString c s) = c `B.cons` s + + +showHex4::Int->String +showHex4 i = replicate (4 - length rawOutput) '0' ++ rawOutput + where rawOutput = showHex i "" + +formatOp::Operation->String +formatOp (PUSH x) = "PUSH" ++ show (length x) -- ++ show x +formatOp x = show x + +formatAddressWithoutColor::Address->String +formatAddressWithoutColor (Address x) = padZeros 40 $ showHex x "" + + +runCode::Environment->VMState->Int->ContextM VMState +runCode env state c = do + memBefore <- liftIO $ getSizeInWords $ memory state + let (op, len) = getOperationAt (envCode env) (pc state) + --liftIO $ putStrLn $ "EVM [ 19:22" ++ show op ++ " #" ++ show c ++ " (" ++ show (vmGasRemaining state) ++ ")" + state' <- decreaseGasForOp op state + result <- runOperation op env state' + memAfter <- liftIO $ getSizeInWords $ memory result + liftIO $ putStrLn $ "EVM [ eth | " ++ show (callDepth state) ++ " | " ++ formatAddressWithoutColor (envOwner env) ++ " | #" ++ show c ++ " | " ++ map toUpper (showHex4 (pc state)) ++ " : " ++ formatOp op ++ " | " ++ show (vmGasRemaining state) ++ " | " ++ show (vmGasRemaining result - vmGasRemaining state) ++ " | " ++ show(toInteger memAfter - toInteger memBefore) ++ "x32 ]" + --liftIO $ putStrLn $ "EVM [ 19:23:05 | eth | " ++ show (callDepth state) ++ " | " ++ formatAddressWithoutColor (envOwner env) ++ " | #" ++ show c ++ " | " ++ map toUpper (showHex4 (pc state)) ++ " : " ++ formatOp op ++ " | " ++ show (vmGasRemaining state) ++ " | " ++ show (vmGasRemaining result - vmGasRemaining state) ++ " | " ++ show(toInteger memAfter - toInteger memBefore) ++ "x32 ]" + memString <- liftIO $ getShow (memory result) + liftIO $ putStrLn $ " > memory: " ++ memString + liftIO $ putStrLn "STACK" + liftIO $ putStrLn $ unlines ((" " ++) <$> padZeros 64 <$> flip showHex "" <$> stack result) + liftIO $ putStrLn "STORAGE" + kvs <- getStorageKeyVals "" + liftIO $ putStrLn $ unlines (map (\(k, v) -> "0x" ++ showHex (byteString2Integer $ nibbleString2ByteString k) "" ++ ": 0x" ++ showHex (rlpDecode $ rlpDeserialize $ rlpDecode v::Integer) "") kvs) + case result of + VMState{vmException=Just _} -> return result{ vmGasRemaining = 0 } + VMState{done=True} -> return $ movePC result len + state2 -> runCode env (movePC state2 len) (c+1) + +runCodeFromStart::Address->Int->Integer->Environment->ContextM (VMState, SHAPtr) +runCodeFromStart address callDepth' gasLimit' env = do + addressState <- getAddressState address + --liftIO $ putStrLn $ "Running code:\n Input Data = " ++ format (envInputData env) + oldStateRoot <- getStorageStateRoot + setStorageStateRoot (contractRoot addressState) + + vmState <- liftIO startingState + state' <- runCode env vmState{callDepth=callDepth', vmGasRemaining=gasLimit'} 0 + + newStateRoot <- getStorageStateRoot + --newAddressState <- getAddressState address + --putAddressState address newAddressState{contractRoot=newStateRoot} + setStorageStateRoot oldStateRoot + + return (state', newStateRoot) + + +nestedRun::Environment->VMState->Word256->Address->Word256->B.ByteString->ContextM (VMState, Maybe B.ByteString) +nestedRun env state gas address value inputData = do + + theBalance <- fmap balance $ getAddressState $ envOwner env + + if theBalance < fromIntegral value + then return (state{stack=0:stack state}, Nothing) + else do + + pay (envOwner env) address (fromIntegral value) + + addressState <- getAddressState address + code <- + fromMaybe B.empty <$> + getCode (codeHash addressState) + + + (nestedState, newStorageStateRoot) <- + runCodeFromStart address (callDepth state + 1) + (fromIntegral gas) + Environment { + envOwner = address, + envOrigin = envOrigin env, + envGasPrice = envGasPrice env, + envInputData = inputData, + envSender = envOwner env, + envValue = fromIntegral value, + envCode = Code code, + envBlock = envBlock env + } + + let retVal = fromMaybe B.empty $ returnVal nestedState + + {-state' <- + if storeRetVal + then do + liftIO $ mStoreByteString state outOffset retVal + else return state-} + + let usedGas = fromIntegral gas - vmGasRemaining nestedState + + let success = + case vmException nestedState of + Nothing -> 1 + _ -> 0 + + addressState' <- getAddressState address + putAddressState address addressState'{contractRoot=newStorageStateRoot} + + return (state{stack=success:stack state, vmGasRemaining = vmGasRemaining state - usedGas}, Just retVal) diff --git a/src/Blockchain/VM/Code.hs b/src/Blockchain/VM/Code.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/VM/Code.hs @@ -0,0 +1,35 @@ + +module Blockchain.VM.Code where + +import qualified Data.ByteString as B +import Text.PrettyPrint.ANSI.Leijen + +import Blockchain.Data.RLP +import Blockchain.Format +import Blockchain.VM.Opcodes + +newtype Code = Code B.ByteString deriving (Show) + + + +getOperationAt::Code->Int->(Operation, Int) +getOperationAt (Code rom) p = opCode2Op $ B.drop p rom + +showCode::Int->Code->String +showCode _ (Code rom) | B.null rom = "" +showCode lineNumber c@(Code rom) = show lineNumber ++ " " ++ format (B.pack $ op2OpCode op) ++ " " ++ show (pretty op) ++ "\n" ++ showCode (lineNumber + nextP) (Code $ B.drop nextP rom) + where + (op, nextP) = getOperationAt c 0 + +instance Pretty Code where + pretty = text . showCode 0 + +instance RLPSerializable Code where + rlpEncode (Code rom) = rlpEncode rom + rlpDecode = Code . rlpDecode + +codeLength::Code->Int +codeLength (Code c) = B.length c + +compile::[Operation]->Code +compile x = Code $ B.pack $ op2OpCode =<< x diff --git a/src/Blockchain/VM/Environment.hs b/src/Blockchain/VM/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/VM/Environment.hs @@ -0,0 +1,21 @@ + +module Blockchain.VM.Environment where + +import qualified Data.ByteString as B + +import Blockchain.Data.Address +import Blockchain.Data.Block +import Blockchain.VM.Code + +data Environment = + Environment { + envOwner::Address, + envOrigin::Address, + envGasPrice::Integer, + envInputData::B.ByteString, + envSender::Address, + envValue::Integer, + envCode::Code, + envBlock::Block + } + diff --git a/src/Blockchain/VM/Labels.hs b/src/Blockchain/VM/Labels.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/VM/Labels.hs @@ -0,0 +1,78 @@ + +module Blockchain.VM.Labels + ( + lcompile, + getLabel, + getNextLabels + ) where + +import qualified Data.ByteString as B +import qualified Data.Map as M +import Data.Maybe + +import Blockchain.ExtWord +import Blockchain.Util +import Blockchain.VM.Opcodes + +--import Debug.Trace + +type Labels = M.Map String Word256 + +lcompile::[Operation]->[Operation] +lcompile ops = substituteLabels labels ops + where + labels = calculateBestLabels ops + +--Returns a list of labelnames, with obviously wrong positions which use all 32Bytes. +--This gives a bad starting guess, but a maximally conservative one (space wise), which can then be +--iteratively fixed. +getStupidLabels::[Operation]->Labels +getStupidLabels ops = M.fromList $ op2StupidLabels =<< ops + where + op2StupidLabels::Operation->[(String, Word256)] + op2StupidLabels (LABEL name) = [(name, -1)] + op2StupidLabels _ = [] + +getBetterLabels::[Operation]->Labels->Labels +getBetterLabels ops oldLabels = M.fromList $ op2Labels oldLabels 0 ops + where + op2Labels::Labels->Word256->[Operation]->[(String, Word256)] + op2Labels _ _ [] = [] + op2Labels oldLabs p (LABEL name:rest) = (name, p):op2Labels oldLabs p rest + op2Labels oldLabs p (x:rest) = op2Labels oldLabs (p+opSize oldLabs x) rest + + opSize::Labels->Operation->Word256 + opSize _ (LABEL _) = 0 + opSize _ (DATA bytes) = fromIntegral $ B.length bytes + opSize labels (PUSHLABEL x) = 1+fromIntegral (length $ integer2Bytes $ fromIntegral $ getLabel labels x) + opSize labels (PUSHDIFF start end) = + 1+fromIntegral (length $ integer2Bytes $ fromIntegral (getLabel labels end - getLabel labels start)) + opSize _ (PUSH x) = 1+fromIntegral (length x) + opSize _ _ = 1 + +calculateBestLabels::[Operation]->Labels +calculateBestLabels ops = + let + first = getStupidLabels ops + second = getBetterLabels ops first + third = getBetterLabels ops second + in third + + +getLabel::Labels->String->Word256 +getLabel labels label = fromMaybe (error $ "Missing label: " ++ show label) $ M.lookup label labels + +getNextLabels::(Labels->[Operation])->Labels +getNextLabels = error "getNextLabels undefined" + +substituteLabels::Labels->[Operation]->[Operation] +substituteLabels labels ops = substituteLabel labels =<< ops + where + substituteLabel::Labels->Operation->[Operation] + substituteLabel _ (LABEL _) = [] + substituteLabel _ (PUSHDIFF start end) = [PUSH $ integer2Bytes1 $ toInteger (getLabel labels end - getLabel labels start)] + substituteLabel labs (PUSHLABEL name) = [PUSH $ integer2Bytes1 $ toInteger (getLabel labs name)] + substituteLabel _ x = [x] + + + diff --git a/src/Blockchain/VM/Memory.hs b/src/Blockchain/VM/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/VM/Memory.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +module Blockchain.VM.Memory ( + Memory(..), + getSizeInBytes, + getSizeInWords, + getShow, + mLoad, + mLoad8, + mLoadByteString, + mStore, + mStore8, + mStoreByteString + ) where + +import Control.Monad +import qualified Data.Vector.Unboxed.Mutable as V +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B16 +import Data.Functor +import Data.IORef +import Data.Word +--import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.ExtWord +import Blockchain.Util +import Blockchain.VM.VMState + +getSizeInWords::Memory->IO Word256 +getSizeInWords (Memory _ size) = (ceiling . (/ (32::Double)) . fromIntegral) <$> readIORef size + +getSizeInBytes::Memory->IO Word256 +getSizeInBytes (Memory _ size) = (1+) <$> readIORef size + +--In this function I use the words "size" and "length" to mean 2 different things.... +--"size" is the highest memory location used (as described in the yellowpaper). +--"length" is the IOVector length, which will often be larger than the size. +--Basically, to avoid resizing the vector constantly (which could be expensive), +--I keep something larger around until it fills up, then reallocate (something even +--larger). +setNewMaxSize::VMState->Word256->IO VMState +setNewMaxSize state newSize = do + oldSize <- readIORef (mSize $ memory state) + when (newSize > oldSize) $ do + writeIORef (mSize $ memory state) newSize + + let gasCharge = + if newSize > oldSize + then fromInteger $ (ceiling $ fromIntegral newSize/(32::Double)) - (ceiling $ fromIntegral oldSize/(32::Double)) + else 0 + + let oldLength = fromIntegral $ V.length (mVector $ memory state) + state' <- + if newSize > oldLength + then do + arr' <- V.grow (mVector $ memory state) $ fromIntegral $ 2*newSize + forM_ [oldLength-1..2*oldLength-1] $ \p -> V.write arr' (fromIntegral p) 0 + return $ state{memory=(memory state){mVector = arr'}} + else return state + + return state'{vmGasRemaining=vmGasRemaining state - gasCharge} + +getShow::Memory->IO String +getShow (Memory arr sizeRef) = do + msize <- readIORef sizeRef + --fmap (show . B16.encode . B.pack) $ sequence $ V.read arr <$> fromIntegral <$> [0..fromIntegral msize-1] + fmap (show . B16.encode . B.pack) $ sequence $ V.read arr <$> [0..fromIntegral msize-1] + + +mLoad::VMState->Word256->IO [Word8] +mLoad state p = do + --setNewMaxSize m (p+31) + sequence $ V.read (mVector $ memory state) <$> fromIntegral <$> [p..p+31] + +mLoad8::VMState->Word256->IO Word8 +mLoad8 state p = do + --setNewMaxSize m p + V.read (mVector $ memory state) (fromIntegral p) + +mLoadByteString::VMState->Word256->Word256->IO B.ByteString +mLoadByteString state p size = do + --setNewMaxSize m (p+size) + fmap B.pack $ sequence $ V.read (mVector $ memory state) <$> fromIntegral <$> [p..p+size-1] + + +mStore::VMState->Word256->Word256->IO VMState +mStore state p val = do + state' <- setNewMaxSize state (p+32) + sequence_ $ uncurry (V.write $ mVector $ memory state') <$> zip [fromIntegral p..] (word256ToBytes val) + return state' + +mStore8::VMState->Word256->Word8->IO VMState +mStore8 state p val = do + state' <- setNewMaxSize state p + V.write (mVector $ memory state') (fromIntegral p) val + return state' + +mStoreByteString::VMState->Word256->B.ByteString->IO VMState +mStoreByteString state p theData = do + state' <- setNewMaxSize state (p + fromIntegral (B.length theData)) + sequence_ $ uncurry (V.write $ mVector $ memory state') <$> zip (fromIntegral <$> [p..p+fromIntegral (B.length theData)]) (B.unpack theData) + return state' + diff --git a/src/Blockchain/VM/Opcodes.hs b/src/Blockchain/VM/Opcodes.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/VM/Opcodes.hs @@ -0,0 +1,195 @@ + +module Blockchain.VM.Opcodes where + +import Prelude hiding (LT, GT, EQ) + +import Data.Binary +import qualified Data.ByteString as B +import Data.Functor +import qualified Data.Map as M +import Data.Maybe +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import Blockchain.Util + +--import Debug.Trace + +data Operation = + STOP | ADD | MUL | SUB | DIV | SDIV | MOD | SMOD | ADDMOD | MULMOD | EXP | SIGNEXTEND | NEG | LT | GT | SLT | SGT | EQ | ISZERO | NOT | AND | OR | XOR | BYTE | SHA3 | + ADDRESS | BALANCE | ORIGIN | CALLER | CALLVALUE | CALLDATALOAD | CALLDATASIZE | CALLDATACOPY | CODESIZE | CODECOPY | GASPRICE | EXTCODESIZE | EXTCODECOPY | + PREVHASH | COINBASE | TIMESTAMP | NUMBER | DIFFICULTY | GASLIMIT | POP | MLOAD | MSTORE | MSTORE8 | SLOAD | SSTORE | + JUMP | JUMPI | PC | MSIZE | GAS | JUMPDEST | + PUSH [Word8] | + DUP1 | DUP2 | DUP3 | DUP4 | + DUP5 | DUP6 | DUP7 | DUP8 | + DUP9 | DUP10 | DUP11 | DUP12 | + DUP13 | DUP14 | DUP15 | DUP16 | + SWAP1 | SWAP2 | SWAP3 | SWAP4 | + SWAP5 | SWAP6 | SWAP7 | SWAP8 | + SWAP9 | SWAP10 | SWAP11 | SWAP12 | + SWAP13 | SWAP14 | SWAP15 | SWAP16 | + LOG0 | LOG1 | LOG2 | LOG3 | LOG4 | + CREATE | CALL | RETURN | CALLCODE | SUICIDE | + --Pseudo Opcodes + LABEL String | PUSHLABEL String | + PUSHDIFF String String | DATA B.ByteString | + MalformedOpcode Word8 deriving (Show, Eq, Ord) + +instance Pretty Operation where + pretty x@JUMPDEST = text $ "------" ++ show x + pretty x@(PUSH vals) = text $ show x ++ " --" ++ show (bytes2Integer vals) + pretty x = text $ show x + +data OPData = OPData Word8 Operation Int Int String + +type EthCode = [Operation] + +singleOp::Operation->([Word8]->Operation, Int) +singleOp o = (const o, 1) + +opDatas::[OPData] +opDatas = + [ + OPData 0x00 STOP 0 0 "Halts execution.", + OPData 0x01 ADD 2 1 "Addition operation.", + OPData 0x02 MUL 2 1 "Multiplication operation.", + OPData 0x03 SUB 2 1 "Subtraction operation.", + OPData 0x04 DIV 2 1 "Integer division operation.", + OPData 0x05 SDIV 2 1 "Signed integer division operation.", + OPData 0x06 MOD 2 1 "Modulo remainder operation.", + OPData 0x07 SMOD 2 1 "Signed modulo remainder operation.", + OPData 0x08 ADDMOD 2 1 "unsigned modular addition", + OPData 0x09 MULMOD 2 1 "unsigned modular multiplication", + OPData 0x0a EXP 2 1 "Exponential operation.", + OPData 0x0b SIGNEXTEND undefined undefined undefined, + + OPData 0x10 LT 2 1 "Less-than comparision.", + OPData 0x11 GT 2 1 "Greater-than comparision.", + OPData 0x12 SLT 2 1 "Signed less-than comparision.", + OPData 0x13 SGT 2 1 "Signed greater-than comparision.", + OPData 0x14 EQ 2 1 "Equality comparision.", + OPData 0x15 ISZERO 1 1 "Simple not operator.", + OPData 0x16 AND 2 1 "Bitwise AND operation.", + OPData 0x17 OR 2 1 "Bitwise OR operation.", + OPData 0x18 XOR 2 1 "Bitwise XOR operation.", + OPData 0x19 NOT 1 1 "Bitwise not operator.", + OPData 0x1a BYTE 2 1 "Retrieve single byte from word.", + + OPData 0x20 SHA3 2 1 "Compute SHA3-256 hash.", + + OPData 0x30 ADDRESS 0 1 "Get address of currently executing account.", + OPData 0x31 BALANCE 1 1 "Get balance of the given account.", + OPData 0x32 ORIGIN 0 1 "Get execution origination address.", + OPData 0x33 CALLER 0 1 "Get caller address.", + OPData 0x34 CALLVALUE 0 1 "Get deposited value by the instruction/transaction responsible for this execution.", + OPData 0x35 CALLDATALOAD 1 1 "Get input data of current environment.", + OPData 0x36 CALLDATASIZE 0 1 "Get size of input data in current environment.", + OPData 0x37 CALLDATACOPY 3 0 "Copy input data in current environment to memory.", + OPData 0x38 CODESIZE 0 1 "Get size of code running in current environment.", + OPData 0x39 CODECOPY 3 0 "Copy code running in current environment to memory.", + OPData 0x3a GASPRICE 0 1 "Get price of gas in current environment.", + OPData 0x3b EXTCODESIZE undefined undefined "get external code size (from another contract)", + OPData 0x3c EXTCODECOPY undefined undefined "copy external code (from another contract)", + + OPData 0x40 PREVHASH 0 1 "Get hash of most recent complete block.", + OPData 0x41 COINBASE 0 1 "Get the block’s coinbase address.", + OPData 0x42 TIMESTAMP 0 1 "Get the block’s timestamp.", + OPData 0x43 NUMBER 0 1 "Get the block’s number.", + OPData 0x44 DIFFICULTY 0 1 "Get the block’s difficulty.", + OPData 0x45 GASLIMIT 0 1 "Get the block’s gas limit.", + + OPData 0x50 POP 1 0 "Remove item from stack.", + OPData 0x51 MLOAD 1 1 "Load word from memory.", + OPData 0x52 MSTORE 2 0 "Save word to memory.", + OPData 0x53 MSTORE8 2 0 "Save byte to memory.", + OPData 0x54 SLOAD 1 1 "Load word from storage.", + OPData 0x55 SSTORE 2 0 "Save word to storage.", + OPData 0x56 JUMP 1 0 "Alter the program counter.", + OPData 0x57 JUMPI 2 0 "Conditionally alter the program counter.", + OPData 0x58 PC 0 1 "Get the program counter.", + OPData 0x59 MSIZE 0 1 "Get the size of active memory in bytes.", + OPData 0x5a GAS 0 1 "Get the amount of available gas.", + OPData 0x5b JUMPDEST 0 0 "set a potential jump destination", + + OPData 0x80 DUP1 0 1 undefined, + OPData 0x81 DUP2 0 1 undefined, + OPData 0x82 DUP3 0 1 undefined, + OPData 0x83 DUP4 0 1 undefined, + OPData 0x84 DUP5 0 1 undefined, + OPData 0x85 DUP6 0 1 undefined, + OPData 0x86 DUP7 0 1 undefined, + OPData 0x87 DUP8 0 1 undefined, + OPData 0x88 DUP9 0 1 undefined, + OPData 0x89 DUP10 0 1 undefined, + OPData 0x8a DUP11 0 1 undefined, + OPData 0x8b DUP12 0 1 undefined, + OPData 0x8c DUP13 0 1 undefined, + OPData 0x8d DUP14 0 1 undefined, + OPData 0x8e DUP15 0 1 undefined, + OPData 0x8f DUP16 0 1 undefined, + + OPData 0x90 SWAP1 0 0 undefined, + OPData 0x91 SWAP2 0 0 undefined, + OPData 0x92 SWAP3 0 0 undefined, + OPData 0x93 SWAP4 0 0 undefined, + OPData 0x94 SWAP5 0 0 undefined, + OPData 0x95 SWAP6 0 0 undefined, + OPData 0x96 SWAP7 0 0 undefined, + OPData 0x97 SWAP8 0 0 undefined, + OPData 0x98 SWAP9 0 0 undefined, + OPData 0x99 SWAP10 0 0 undefined, + OPData 0x9a SWAP11 0 0 undefined, + OPData 0x9b SWAP12 0 0 undefined, + OPData 0x9c SWAP13 0 0 undefined, + OPData 0x9d SWAP14 0 0 undefined, + OPData 0x9e SWAP15 0 0 undefined, + OPData 0x9f SWAP16 0 0 undefined, + + OPData 0xa0 LOG0 undefined undefined undefined, + OPData 0xa1 LOG1 undefined undefined undefined, + OPData 0xa2 LOG2 undefined undefined undefined, + OPData 0xa3 LOG3 undefined undefined undefined, + OPData 0xa4 LOG4 undefined undefined undefined, + + OPData 0xf0 CREATE 3 1 "Create a new account with associated code.", + OPData 0xf1 CALL 7 1 "Message-call into an account.", + OPData 0xf2 CALLCODE undefined undefined "message-call with another account's code only", + OPData 0xf3 RETURN 2 0 "Halt execution returning output data.", + OPData 0xff SUICIDE 1 0 "Halt execution and register account for later deletion." + ] + + +op2CodeMap::M.Map Operation Word8 +op2CodeMap=M.fromList $ (\(OPData code op _ _ _) -> (op, code)) <$> opDatas + +code2OpMap::M.Map Word8 Operation +code2OpMap=M.fromList $ (\(OPData opcode op _ _ _) -> (opcode, op)) <$> opDatas + +op2OpCode::Operation->[Word8] +op2OpCode (PUSH theList) | length theList <= 32 && not (null theList) = + 0x5F + fromIntegral (length theList):theList +op2OpCode (PUSH []) = error "PUSH needs at least one word" +op2OpCode (PUSH x) = error $ "PUSH can only take up to 32 words: " ++ show x +op2OpCode (DATA bytes) = B.unpack bytes +op2OpCode op = + case M.lookup op op2CodeMap of + Just x -> [x] + Nothing -> error $ "op is missing in op2CodeMap: " ++ show op + +opLen::Operation->Int +opLen (PUSH x) = 1 + length x +opLen _ = 1 + +opCode2Op::B.ByteString->(Operation, Int) +opCode2Op rom | B.null rom = (STOP, 1) --according to the yellowpaper, should return STOP if outside of the code bytestring +opCode2Op rom = + let opcode = B.head rom in + if opcode >= 0x60 && opcode <= 0x7f + then (PUSH $ B.unpack $ B.take (fromIntegral $ opcode-0x5F) $ B.tail rom, fromIntegral $ opcode - 0x5E) + else +-- let op = fromMaybe (error $ "code is missing in code2OpMap: 0x" ++ showHex (B.head rom) "") + let op = fromMaybe (MalformedOpcode opcode) + $ M.lookup opcode code2OpMap in + (op, 1) + + diff --git a/src/Blockchain/VM/VMState.hs b/src/Blockchain/VM/VMState.hs new file mode 100644 --- /dev/null +++ b/src/Blockchain/VM/VMState.hs @@ -0,0 +1,94 @@ + +module Blockchain.VM.VMState ( + VMState(..), + Memory(..), + startingState, + VMException(..), + addErr +-- getReturnValue + ) where + +import Control.Monad +import qualified Data.Vector.Unboxed.Mutable as V +import qualified Data.ByteString as B +import Data.IORef +import Data.Word + + +import Blockchain.ExtWord +import Blockchain.Format +import Blockchain.VM.Code + +data VMException = OutOfGasException | StackTooSmallException | VMException String | MalformedOpcodeException deriving (Show) + +addErr::String->Code->VMState->IO VMState +addErr message c state = do + let (op, _) = getOperationAt c (pc state) + return state{vmException=Just $ VMException (message ++ " for a call to " ++ show op)} + +data Memory = + Memory { + mVector::V.IOVector Word8, + mSize::IORef Word256 + } + + +newMemory::IO Memory +newMemory = do + arr <- V.new 100 + size <- newIORef 0 + forM_ [0..99] $ \p -> V.write arr p 0 + return $ Memory arr size + +data VMState = + VMState { + vmGasRemaining::Integer, + pc::Int, + memory::Memory, + stack::[Word256], + callDepth::Int, + refund::Integer, + + markedForSuicide::Bool, + done::Bool, + returnVal::Maybe B.ByteString, + + vmException::Maybe VMException + } + + +instance Format VMState where + format state = + "pc: " ++ show (pc state) ++ "\n" ++ + "done: " ++ show (done state) ++ "\n" ++ + "gasRemaining: " ++ show (vmGasRemaining state) ++ "\n" ++ + "stack: " ++ show (stack state) ++ "\n" + +startingState::IO VMState +startingState = do + m <- newMemory + return VMState + { + pc = 0, + done=False, + returnVal=Nothing, + vmException=Nothing, + vmGasRemaining=0, + stack=[], + memory=m, + callDepth=0, + refund=0, + markedForSuicide=False + } + +{- +getReturnValue::VMState->IO B.ByteString +getReturnValue state = + case stack state of + [add, size] -> mLoadByteString (memory state) add size + [] -> return B.empty --Happens when STOP is called + --TODO- This needs better error handling other than to just crash if the stack isn't 2 items long + _ -> error "Error in getReturnValue: VM ended with stack in an unsupported case" + + +-}