├── .gitignore ├── fastNonceFinder ├── Makefile ├── CREDIT ├── test.c ├── sha3.h ├── nonceFinder.c ├── sha3.c └── bitfn.h ├── startPeer ├── Setup.hs ├── src └── Blockchain │ ├── VM │ ├── Environment.hs │ ├── Code.hs │ ├── PrecompiledContracts.hs │ ├── Labels.hs │ ├── VMState.hs │ ├── OpcodePrices.hs │ ├── VMM.hs │ ├── Memory.hs │ └── Opcodes.hs │ ├── Data │ ├── Peer.hs │ ├── TransactionReceipt.hs │ ├── GenesisBlock.hs │ └── Wire.hs │ ├── Communication.hs │ ├── DB │ └── ModifyStateDB.hs │ ├── Mining.hs │ ├── Display.hs │ ├── BlockSynchronizer.hs │ ├── JCommand.hs │ ├── Context.hs │ ├── PeerUrls.hs │ ├── SampleTransactions.hs │ ├── BlockChain.hs │ └── VM.hs ├── POC5ToPOC6ChangeLog ├── LICENSE ├── test └── Main.hs ├── README ├── ethereum-client-haskell.cabal └── exec_src └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *~ 3 | dist 4 | .DS_Store -------------------------------------------------------------------------------- /fastNonceFinder/Makefile: -------------------------------------------------------------------------------- 1 | 2 | LDLIBS= -lpthread 3 | 4 | test: sha3.o 5 | -------------------------------------------------------------------------------- /startPeer: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | while true 4 | do 5 | ethereumH 0 6 | sleep 10 7 | done 8 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main (main) where 3 | 4 | import Distribution.Simple 5 | 6 | main :: IO () 7 | main = defaultMain 8 | 9 | -------------------------------------------------------------------------------- /fastNonceFinder/CREDIT: -------------------------------------------------------------------------------- 1 | The files bitfn.h, sha3.c, and sha3.h were taken from the Haskell/Hackage package 2 | 3 | cryptohash-0.11.6 4 | 5 | -------------------------------------------------------------------------------- /src/Blockchain/VM/Environment.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.VM.Environment where 3 | 4 | import qualified Data.ByteString as B 5 | 6 | import Blockchain.Data.Address 7 | import Blockchain.Data.DataDefs 8 | import Blockchain.Data.Code 9 | import Blockchain.ExtWord 10 | 11 | data Environment = 12 | Environment { 13 | envOwner::Address, 14 | envOrigin::Address, 15 | envGasPrice::Integer, 16 | envInputData::B.ByteString, 17 | envSender::Address, 18 | envValue::Integer, 19 | envCode::Code, 20 | envJumpDests::[Word256], 21 | envBlock::Block 22 | } 23 | 24 | -------------------------------------------------------------------------------- /fastNonceFinder/test.c: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #include "nonceFinder.c" 9 | 10 | 11 | void usage() { 12 | printf("Usage:\n"); 13 | printf(" test <256 bit data> <256 bit threshold>\n"); 14 | exit(1); 15 | } 16 | 17 | int main(int argc, char **argv) { 18 | 19 | uint8_t out[32]; 20 | 21 | if (argc != 3) usage(); 22 | 23 | if (strlen(argv[1]) != 64) usage(); 24 | if (strlen(argv[2]) != 64) usage(); 25 | 26 | uint8_t globalThreshold[32]; 27 | uint8_t globalData[32]; 28 | 29 | int i; 30 | char *p1 = argv[1]; 31 | char *p2 = argv[2]; 32 | 33 | for(i = 0; i < 32; i++) { 34 | sscanf(p1, "%2hhx", &globalData[i]); 35 | sscanf(p2, "%2hhx", &globalThreshold[i]); 36 | p1 += 2; 37 | p2 += 2; 38 | } 39 | 40 | findNonce(globalData, globalThreshold, out); 41 | 42 | print256(out); 43 | 44 | return 0; 45 | 46 | } 47 | -------------------------------------------------------------------------------- /POC5ToPOC6ChangeLog: -------------------------------------------------------------------------------- 1 | 2 | 1. Block target time moved from 42 seconds to 5 seconds. 3 | 4 | 2. Added block uncles reward (this probably existed in POC5, I just didn't see it for some reason). 5 | 6 | 3. Block synchronization changed (use GetBlockHashes, BlockHashes, GetBlocks, Blocks now, and the request is done in two phases, first get hashes then blocks. A lot of the logic changed, and a list of needed items was added to the context). 7 | 8 | 4. codeHash is stored as a single zero in AddressState if blank, rather than the hash of an empty bytestring. 9 | 10 | 5. Starting difficulty is now 0x20000. 11 | 12 | 6. If transaction "to" address is blank, it is encoded as number 0, not 20 bytes (160 bits) worth of zeros. 13 | 14 | 7. "Hello" message has changed.... Capabilities are stored as an array of strings now. 15 | 16 | 8. Other new messages added: "Status" and "WhisperProtocolVersion". Corresponding logic had to change a litte bit. 17 | 18 | 19 | 20 | Also, I performed a bunch of cleanup. 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/Blockchain/Data/Peer.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.Data.Peer ( 3 | Peer(..) 4 | ) where 5 | 6 | import Data.ByteString.Internal 7 | import Data.Word 8 | 9 | import Blockchain.Format 10 | import Blockchain.Data.RLP 11 | 12 | --import Debug.Trace 13 | 14 | 15 | 16 | --instance Show Block where 17 | -- show x = "" 18 | 19 | 20 | 21 | data IPAddr = IPAddr Word8 Word8 Word8 Word8 deriving (Show) 22 | 23 | instance Format IPAddr where 24 | format (IPAddr v1 v2 v3 v4) = show v1 ++ "." ++ show v2 ++ "." ++ show v3 ++ "." ++ show v4 25 | 26 | data Peer = Peer { 27 | ipAddr::IPAddr, 28 | peerPort::Word16, 29 | uniqueId::String 30 | } deriving (Show) 31 | 32 | instance Format Peer where 33 | format peer = format (ipAddr peer) ++ ":" ++ show (peerPort peer) 34 | 35 | instance RLPSerializable Peer where 36 | rlpDecode (RLPArray [RLPString [c1,c2,c3,c4], port, RLPString uid]) = 37 | Peer { 38 | ipAddr = IPAddr (c2w c1) (c2w c2) (c2w c3) (c2w c4), 39 | peerPort = fromInteger $ rlpDecode port, 40 | uniqueId = uid 41 | } 42 | rlpDecode x = error ("rlp2Peer called on non block object: " ++ show x) 43 | 44 | rlpEncode = error "rlpEncode undefined for Peer" 45 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Copyright (c) 2014, Jamshid 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /src/Blockchain/VM/Code.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.VM.Code where 3 | 4 | import qualified Data.ByteString as B 5 | import Network.Haskoin.Internals 6 | import Numeric 7 | import Text.PrettyPrint.ANSI.Leijen 8 | 9 | import Blockchain.Data.Code 10 | import Blockchain.Format 11 | import Blockchain.Util 12 | import Blockchain.VM.Opcodes 13 | 14 | 15 | getOperationAt::Code->Word256->(Operation, Word256) 16 | getOperationAt (Code bytes) p = getOperationAt' bytes p 17 | 18 | getOperationAt'::B.ByteString->Word256->(Operation, Word256) 19 | getOperationAt' rom p = opCode2Op $ safeDrop p rom 20 | 21 | showCode::Word256->Code->String 22 | showCode _ (Code bytes) | B.null bytes = "" 23 | showCode lineNumber c@(Code rom) = showHex lineNumber "" ++ " " ++ format (B.pack $ op2OpCode op) ++ " " ++ show (pretty op) ++ "\n" ++ showCode (lineNumber + nextP) (Code (safeDrop nextP rom)) 24 | where 25 | (op, nextP) = getOperationAt c 0 26 | 27 | instance Pretty Code where 28 | pretty = text . showCode 0 29 | 30 | getValidJUMPDESTs::Code->[Word256] 31 | getValidJUMPDESTs (Code bytes) = 32 | map fst $ filter ((== JUMPDEST) . snd) $ getOps bytes 0 33 | where 34 | getOps::B.ByteString->Word256->[(Word256, Operation)] 35 | getOps bytes' p | p > fromIntegral (B.length bytes') = [] 36 | getOps code p = (p, op):getOps code (p+len) 37 | where 38 | (op, len) = getOperationAt' code p 39 | 40 | 41 | codeLength::Code->Int 42 | codeLength (Code bytes) = B.length bytes 43 | 44 | compile::[Operation]->Code 45 | compile x = Code bytes 46 | where 47 | bytes = B.pack $ op2OpCode =<< x 48 | 49 | -------------------------------------------------------------------------------- /src/Blockchain/Communication.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.Communication ( 3 | recvMsg, 4 | sendMsg 5 | ) where 6 | 7 | import Control.Monad.IO.Class 8 | import Control.Monad.Trans 9 | import Data.Binary.Put 10 | import qualified Data.ByteString as B 11 | import qualified Data.ByteString.Lazy as BL 12 | import System.IO 13 | 14 | import Blockchain.Data.RLP 15 | 16 | import Blockchain.Context 17 | import Blockchain.Display 18 | import Blockchain.Data.Wire 19 | import Blockchain.Frame 20 | import Blockchain.RLPx 21 | 22 | ethereumHeader::B.ByteString->Put 23 | ethereumHeader payload = do 24 | putWord32be 0x22400891 25 | putWord32be $ fromIntegral $ B.length payload 26 | putByteString payload 27 | 28 | 29 | 30 | sendCommand::Handle->B.ByteString->IO () 31 | sendCommand handle payload = do 32 | let theData2 = runPut $ ethereumHeader payload 33 | BL.hPut handle theData2 34 | 35 | sendMessage::Handle->Message->ContextM () 36 | sendMessage handle msg = do 37 | let (pType, pData) = wireMessage2Obj msg 38 | liftIO $ sendCommand handle $ B.cons pType $ rlpSerialize pData 39 | 40 | sendMsg::Message->EthCryptM ContextM () 41 | sendMsg msg = do 42 | lift $ displayMessage True msg 43 | let (pType, pData) = wireMessage2Obj msg 44 | encryptAndPutFrame $ 45 | B.cons pType $ rlpSerialize pData 46 | 47 | recvMsg::EthCryptM ContextM Message 48 | recvMsg = do 49 | frameData <- getAndDecryptFrame 50 | 51 | let packetType = fromInteger $ rlpDecode $ rlpDeserialize $ B.take 1 frameData 52 | packetData = rlpDeserialize $ B.drop 1 frameData 53 | 54 | return $ obj2WireMessage packetType packetData 55 | -------------------------------------------------------------------------------- /src/Blockchain/DB/ModifyStateDB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Blockchain.DB.ModifyStateDB ( 4 | addToBalance, 5 | pay 6 | ) where 7 | 8 | import Control.Monad 9 | import Control.Monad.Trans 10 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 11 | 12 | import Blockchain.Context 13 | import Blockchain.Data.Address 14 | import Blockchain.Data.AddressStateDB 15 | import Blockchain.Data.DataDefs 16 | 17 | --import Debug.Trace 18 | 19 | addToBalance::Address->Integer->ContextM Bool 20 | addToBalance address val = do 21 | addressState <- lift $ getAddressState address 22 | let newVal = addressStateBalance addressState + val 23 | if newVal < 0 24 | then return False 25 | else do 26 | lift $ putAddressState address addressState{addressStateBalance = newVal} 27 | return True 28 | 29 | pay::String->Address->Address->Integer->ContextM Bool 30 | pay description fromAddr toAddr val = do 31 | debug <- isDebugEnabled 32 | when debug $ do 33 | liftIO $ putStrLn $ "payment: from " ++ show (pretty fromAddr) ++ " to " ++ show (pretty toAddr) ++ ": " ++ show val ++ ", " ++ description 34 | fromAddressState <- lift $ getAddressState fromAddr 35 | liftIO $ putStrLn $ "from Funds: " ++ show (addressStateBalance fromAddressState) 36 | toAddressState <- lift $ getAddressState toAddr 37 | liftIO $ putStrLn $ "to Funds: " ++ show (addressStateBalance toAddressState) 38 | when (addressStateBalance fromAddressState < val) $ 39 | liftIO $ putStrLn "insufficient funds" 40 | 41 | fromAddressState <- lift $ getAddressState fromAddr 42 | if addressStateBalance fromAddressState < val 43 | then return False 44 | else do 45 | _ <- addToBalance fromAddr (-val) 46 | _ <- addToBalance toAddr val 47 | return True 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /src/Blockchain/Mining.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.Mining ( 3 | nonceIsValid' 4 | ) where 5 | 6 | 7 | import Control.Monad.IO.Class 8 | import Control.Monad.Trans.State 9 | import qualified Data.Array.IO as A 10 | import qualified Data.Binary as Bin 11 | import qualified Data.ByteString as B 12 | import qualified Data.ByteString.Lazy as BL 13 | import Data.Word 14 | 15 | import Blockchain.Context 16 | import Blockchain.Data.BlockDB 17 | import Blockchain.ExtWord 18 | import Blockchain.Util 19 | import Numeric 20 | 21 | import Cache 22 | import Constants 23 | import Dataset 24 | import Hashimoto 25 | 26 | import Debug.Trace 27 | 28 | 29 | word32Unpack::B.ByteString->[Word32] 30 | word32Unpack s | B.null s = [] 31 | word32Unpack s | B.length s >= 4 = Bin.decode (BL.fromStrict $ B.take 4 s) : word32Unpack (B.drop 4 s) 32 | word32Unpack s = error "word32Unpack called for ByteString of length not a multiple of 4" 33 | 34 | powFunc'::B.ByteString->Block->IO Integer 35 | powFunc' dataset b = 36 | --trace (show $ headerHashWithoutNonce b) $ 37 | fmap (byteString2Integer . snd) $ 38 | hashimoto 39 | (headerHashWithoutNonce b) 40 | (B.pack $ word64ToBytes $ blockDataNonce $ blockBlockData b) 41 | (fromInteger $ fullSize 0) 42 | -- (fromInteger . (calcDataset 0 !)) 43 | (A.newListArray (0,15) . word32Unpack . B.take 64 . (flip B.drop dataset) . (64 *) . fromIntegral) 44 | 45 | nonceIsValid'::Block->ContextM Bool 46 | nonceIsValid' b = do 47 | cxt <- get 48 | 49 | val <- liftIO $ powFunc' (miningDataset cxt) b 50 | 51 | {- 52 | liftIO $ putStrLn (showHex val "") 53 | liftIO $ putStrLn (showHex ( 54 | val * 55 | blockDataDifficulty (blockBlockData b) 56 | ) "") 57 | -} 58 | 59 | return $ val * blockDataDifficulty (blockBlockData b) < (2::Integer)^(256::Integer) 60 | -------------------------------------------------------------------------------- /fastNonceFinder/sha3.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2012 Vincent Hanquez 3 | * 4 | * Redistribution and use in source and binary forms, with or without 5 | * modification, are permitted provided that the following conditions 6 | * are met: 7 | * 1. Redistributions of source code must retain the above copyright 8 | * notice, this list of conditions and the following disclaimer. 9 | * 2. Redistributions in binary form must reproduce the above copyright 10 | * notice, this list of conditions and the following disclaimer in the 11 | * documentation and/or other materials provided with the distribution. 12 | * 13 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 14 | * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 15 | * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 16 | * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 17 | * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 18 | * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 19 | * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 20 | * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 22 | * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | */ 24 | #ifndef CRYPTOHASH_SHA3_H 25 | #define CRYPTOHASH_SHA3_H 26 | 27 | #include 28 | 29 | struct sha3_ctx 30 | { 31 | uint32_t hashlen; /* in bytes */ 32 | uint32_t bufindex; 33 | uint64_t state[25]; 34 | uint32_t bufsz; 35 | uint32_t _padding; 36 | uint8_t buf[144]; /* minimum SHA3-224, otherwise buffer need increases */ 37 | }; 38 | 39 | #define SHA3_CTX_SIZE sizeof(struct sha3_ctx) 40 | 41 | void sha3_init(struct sha3_ctx *ctx, uint32_t hashlen); 42 | void sha3_update(struct sha3_ctx *ctx, uint8_t *data, uint32_t len); 43 | void sha3_finalize(struct sha3_ctx *ctx, uint8_t *out); 44 | 45 | #endif 46 | -------------------------------------------------------------------------------- /src/Blockchain/Display.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.Display ( 3 | addPingCount, 4 | setPeers, 5 | displayMessage 6 | ) where 7 | 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Trans.State 10 | 11 | import qualified Blockchain.Colors as CL 12 | import Blockchain.Context 13 | import Blockchain.Data.Peer 14 | import Blockchain.Format 15 | import Blockchain.Data.Wire 16 | 17 | setTitle::String->IO() 18 | setTitle value = do 19 | putStr $ "\ESC]0;" ++ value ++ "\007" 20 | 21 | updateStatus::ContextM () 22 | updateStatus = do 23 | cxt <- get 24 | liftIO $ setTitle $ 25 | "pingCount = " ++ show (pingCount cxt) 26 | ++ ", peer count=" ++ show (length $ peers cxt) 27 | ++ ", hashes requested=" ++ show (length $ neededBlockHashes cxt) 28 | 29 | addPingCount::ContextM () 30 | addPingCount = do 31 | cxt <- get 32 | put cxt{pingCount = pingCount cxt + 1} 33 | updateStatus 34 | 35 | setPeers::[Peer]->ContextM () 36 | setPeers p = do 37 | cxt <- get 38 | put cxt{peers = p} 39 | updateStatus 40 | 41 | prefix::Bool->String 42 | prefix True = CL.green "msg>>>>>: " 43 | prefix False = CL.cyan "msg<<<<: " 44 | 45 | 46 | displayMessage::Bool->Message->ContextM () 47 | displayMessage _ Ping = return () 48 | displayMessage _ Pong = return () 49 | displayMessage _ GetPeers = return () 50 | displayMessage _ (Peers _) = return () 51 | displayMessage outbound (GetBlocks blocks) = do 52 | liftIO $ putStrLn $ prefix outbound ++ CL.blue "GetBlocks: " ++ "(Requesting " ++ show (length blocks) ++ " blocks)" 53 | displayMessage _ QqqqPacket = return () 54 | displayMessage outbound (BlockHashes shas) = do 55 | liftIO $ putStrLn $ prefix outbound ++ CL.blue "BlockHashes: " ++ "(" ++ show (length shas) ++ " new hashes)" 56 | updateStatus 57 | displayMessage outbound (Blocks blocks) = do 58 | liftIO $ putStrLn $ prefix outbound ++ CL.blue "Blocks: " ++ "(" ++ show (length blocks) ++ " new blocks)" 59 | updateStatus 60 | displayMessage outbound msg = 61 | liftIO $ putStrLn $ (prefix outbound) ++ format msg 62 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Control.Monad 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Trans.Resource 7 | import qualified Data.ByteString as B 8 | import qualified Data.ByteString.Char8 as BC 9 | import Data.Default 10 | import Data.Functor 11 | import Data.List 12 | import Data.Monoid 13 | import qualified Data.Set as S 14 | import System.Exit 15 | import Test.Framework 16 | import Test.Framework.Providers.HUnit 17 | import Test.HUnit 18 | 19 | import qualified Data.NibbleString as N 20 | 21 | import Data.Address 22 | import Format 23 | import DB.ModifyStateDB 24 | import Database.MerklePatricia 25 | import Data.RLP 26 | import SHA 27 | import Util 28 | 29 | putKeyVals::MPDB->[(N.NibbleString, B.ByteString)]->ResourceT IO MPDB 30 | putKeyVals db [(k,v)] = putKeyVal db k (rlpEncode v) 31 | putKeyVals db ((k, v):rest) = do 32 | db'<- putKeyVal db k $ rlpEncode v 33 | putKeyVals db' rest 34 | 35 | verifyDBDataIntegrity::MPDB->[(N.NibbleString, B.ByteString)]->ResourceT IO () 36 | verifyDBDataIntegrity db valuesIn = do 37 | db2 <- initializeBlankStateDB db 38 | db3 <- putKeyVals db2 valuesIn 39 | --return (db, stateRoot2) 40 | valuesOut <- getKeyVals db3 (N.EvenNibbleString B.empty) 41 | liftIO $ assertEqual "empty db didn't match" (S.fromList $ fmap rlpEncode <$> valuesIn) (S.fromList valuesOut) 42 | return () 43 | 44 | testShortcutNodeDataInsert::Assertion 45 | testShortcutNodeDataInsert = do 46 | runResourceT $ do 47 | db <- openDBs False 48 | verifyDBDataIntegrity db 49 | [ 50 | (N.EvenNibbleString $ BC.pack "abcd", BC.pack "abcd"), 51 | (N.EvenNibbleString $ BC.pack "aefg", BC.pack "aefg") 52 | ] 53 | 54 | testFullNodeDataInsert::Assertion 55 | testFullNodeDataInsert = do 56 | runResourceT $ do 57 | db <- openDBs False 58 | verifyDBDataIntegrity db 59 | [ 60 | (N.EvenNibbleString $ BC.pack "abcd", BC.pack "abcd"), 61 | (N.EvenNibbleString $ BC.pack "bb", BC.pack "bb"), 62 | (N.EvenNibbleString $ BC.pack "aefg", BC.pack "aefg") 63 | ] 64 | 65 | main::IO () 66 | main = 67 | defaultMainWithOpts 68 | [ 69 | testCase "ShortcutNodeData Insert" testShortcutNodeDataInsert, 70 | testCase "FullNodeData Insert" testFullNodeDataInsert 71 | ] mempty 72 | -------------------------------------------------------------------------------- /src/Blockchain/Data/TransactionReceipt.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.Data.TransactionReceipt( 3 | TransactionReceipt(..), 4 | PostTransactionState(..) 5 | ) where 6 | 7 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 8 | 9 | import qualified Blockchain.Colors as CL 10 | import Blockchain.Format 11 | import Blockchain.SHA 12 | import Blockchain.Data.SignedTransaction 13 | import Blockchain.Data.RLP 14 | 15 | data PostTransactionState = PostTransactionState SHA deriving (Show) 16 | 17 | instance RLPSerializable PostTransactionState where 18 | rlpDecode x = PostTransactionState $ rlpDecode x 19 | rlpEncode (PostTransactionState x) = rlpEncode x 20 | 21 | data TransactionReceipt = 22 | TransactionReceipt { 23 | theTransaction::SignedTransaction, 24 | postTransactionState::PostTransactionState, 25 | cumulativeGasUsed::Integer 26 | } deriving (Show) 27 | 28 | 29 | {- 30 | nonce: 0x, 31 | gasPrice: 0x09184e72a000, --10000000000000 32 | maxGas: 0x07d0 33 | to: 0x9f840fe058ce3d84e319b8c747accc1e52f69426 34 | , 0x 35 | data: 0x00000000000000000000000000000000000000000000000000000000000003e800000000000000000000000000000000000000000000000000000000000007d000000000000000000000000000000000000000000000000000000000000004d2000\ 36 | 0000000000000000000000000000000000000000000000000000000000001 37 | , 0x1b 38 | , 0x7012b0d1998a049ca767541add20b2a185a6eb0452f637ceb566de87056d9f03 39 | , 0x17f015abaed48196c8d0290bab1aacf82a0e7c02c31618389b2a9990c2731793 40 | -} 41 | 42 | 43 | 44 | 45 | 46 | 47 | instance Format PostTransactionState where 48 | format (PostTransactionState x) = show $ pretty x 49 | 50 | instance Format TransactionReceipt where 51 | format (TransactionReceipt t p gasUsed) = 52 | CL.blue "TransactionReceipt: " ++ show gasUsed ++ "\n" ++ format t ++ "\nPostTransactionState: " ++ format p 53 | 54 | instance RLPSerializable TransactionReceipt where 55 | rlpDecode (RLPArray [t, pts, gasUsed]) = 56 | TransactionReceipt { 57 | theTransaction = rlpDecode t, 58 | postTransactionState = rlpDecode pts, 59 | cumulativeGasUsed = rlpDecode gasUsed 60 | } 61 | rlpDecode x = error $ "Missing case in rlpDecode for TransactionReceipt: " ++ show (pretty x) 62 | 63 | rlpEncode TransactionReceipt{ 64 | theTransaction=t, 65 | postTransactionState=p, 66 | cumulativeGasUsed=gasUsed} = 67 | RLPArray [rlpEncode t, rlpEncode p, rlpEncode gasUsed] 68 | 69 | -------------------------------------------------------------------------------- /src/Blockchain/VM/PrecompiledContracts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Blockchain.VM.PrecompiledContracts ( 4 | callPrecompiledContract 5 | ) where 6 | 7 | import Prelude hiding (LT, GT, EQ) 8 | 9 | import qualified Codec.Digest.SHA as SHA2 10 | import qualified Crypto.Hash.RIPEMD160 as RIPEMD 11 | import Data.Binary hiding (get, put) 12 | import qualified Data.ByteString as B 13 | import qualified Data.ByteString.Lazy as BL 14 | import Network.Haskoin.Internals (Signature(..)) 15 | --import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 16 | 17 | import Blockchain.Data.Address 18 | import Blockchain.ExtendedECDSA 19 | import Blockchain.ExtWord 20 | import Blockchain.Util 21 | import Blockchain.VM.OpcodePrices 22 | import Blockchain.VM.VMM 23 | 24 | 25 | --import Debug.Trace 26 | 27 | ecdsaRecover::B.ByteString->B.ByteString 28 | ecdsaRecover input = 29 | let h = fromInteger $ byteString2Integer $ B.take 32 input 30 | v = byteString2Integer $ B.take 32 $ B.drop 32 input 31 | r = fromInteger $ byteString2Integer $ B.take 32 $ B.drop 64 input 32 | s = fromInteger $ byteString2Integer $ B.take 32 $ B.drop 96 input 33 | maybePubKey = getPubKeyFromSignature (ExtendedSignature (Signature r s) (v == 28)) h 34 | in 35 | case (v >= 27, v <= 28, maybePubKey) of 36 | (True, True, Just pubKey) -> 37 | B.pack [0,0,0,0,0,0,0,0,0,0,0,0] `B.append` BL.toStrict (encode $ pubKey2Address pubKey) 38 | _ -> B.pack (replicate 32 0) 39 | 40 | ripemd::B.ByteString->B.ByteString 41 | ripemd input = 42 | B.replicate 12 0 `B.append` RIPEMD.hash input 43 | 44 | sha2::B.ByteString->B.ByteString 45 | sha2 input = 46 | -- let val = fromInteger $ byteString2Integer $ B.take 32 input 47 | -- in 48 | SHA2.hash SHA2.SHA256 input 49 | 50 | callPrecompiledContract::Word160->B.ByteString->VMM B.ByteString 51 | callPrecompiledContract 0 inputData = return B.empty 52 | 53 | callPrecompiledContract 1 inputData = do 54 | useGas gECRECOVER 55 | return $ ecdsaRecover inputData 56 | 57 | callPrecompiledContract 2 inputData = do 58 | useGas $ gSHA256BASE + gSHA256WORD*(ceiling $ fromIntegral (B.length inputData)/(32::Double)) 59 | return $ sha2 inputData 60 | 61 | callPrecompiledContract 3 inputData = do 62 | useGas $ gRIPEMD160BASE + 63 | gRIPEMD160WORD*(ceiling $ fromIntegral (B.length inputData)/(32::Double)) 64 | return $ ripemd inputData 65 | 66 | callPrecompiledContract 4 inputData = do 67 | useGas $ gIDENTITYBASE + 68 | gIDENTITYWORD*(ceiling $ fromIntegral (B.length inputData)/(32::Double)) 69 | return inputData 70 | 71 | callPrecompiledContract x _ = error $ "missing precompiled contract: " ++ show x 72 | -------------------------------------------------------------------------------- /src/Blockchain/VM/Labels.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.VM.Labels 3 | ( 4 | lcompile, 5 | getLabel, 6 | getNextLabels 7 | ) where 8 | 9 | import qualified Data.ByteString as B 10 | import qualified Data.Map as M 11 | import Data.Maybe 12 | 13 | import Blockchain.ExtWord 14 | import Blockchain.Util 15 | import Blockchain.VM.Opcodes 16 | 17 | --import Debug.Trace 18 | 19 | type Labels = M.Map String Word256 20 | 21 | lcompile::[Operation]->[Operation] 22 | lcompile ops = substituteLabels labels ops 23 | where 24 | labels = calculateBestLabels ops 25 | 26 | --Returns a list of labelnames, with obviously wrong positions which use all 32Bytes. 27 | --This gives a bad starting guess, but a maximally conservative one (space wise), which can then be 28 | --iteratively fixed. 29 | getStupidLabels::[Operation]->Labels 30 | getStupidLabels ops = M.fromList $ op2StupidLabels =<< ops 31 | where 32 | op2StupidLabels::Operation->[(String, Word256)] 33 | op2StupidLabels (LABEL name) = [(name, -1)] 34 | op2StupidLabels _ = [] 35 | 36 | getBetterLabels::[Operation]->Labels->Labels 37 | getBetterLabels ops oldLabels = M.fromList $ op2Labels oldLabels 0 ops 38 | where 39 | op2Labels::Labels->Word256->[Operation]->[(String, Word256)] 40 | op2Labels _ _ [] = [] 41 | op2Labels oldLabs p (LABEL name:rest) = (name, p):op2Labels oldLabs p rest 42 | op2Labels oldLabs p (x:rest) = op2Labels oldLabs (p+opSize oldLabs x) rest 43 | 44 | opSize::Labels->Operation->Word256 45 | opSize _ (LABEL _) = 0 46 | opSize _ (DATA bytes) = fromIntegral $ B.length bytes 47 | opSize labels (PUSHLABEL x) = 1+fromIntegral (length $ integer2Bytes $ fromIntegral $ getLabel labels x) 48 | opSize labels (PUSHDIFF start end) = 49 | 1+fromIntegral (length $ integer2Bytes $ fromIntegral (getLabel labels end - getLabel labels start)) 50 | opSize _ (PUSH x) = 1+fromIntegral (length x) 51 | opSize _ _ = 1 52 | 53 | calculateBestLabels::[Operation]->Labels 54 | calculateBestLabels ops = 55 | let 56 | first = getStupidLabels ops 57 | second = getBetterLabels ops first 58 | third = getBetterLabels ops second 59 | in third 60 | 61 | 62 | getLabel::Labels->String->Word256 63 | getLabel labels label = fromMaybe (error $ "Missing label: " ++ show label) $ M.lookup label labels 64 | 65 | getNextLabels::(Labels->[Operation])->Labels 66 | getNextLabels = error "getNextLabels undefined" 67 | 68 | substituteLabels::Labels->[Operation]->[Operation] 69 | substituteLabels labels ops = substituteLabel labels =<< ops 70 | where 71 | substituteLabel::Labels->Operation->[Operation] 72 | substituteLabel _ (LABEL _) = [] 73 | substituteLabel _ (PUSHDIFF start end) = [PUSH $ integer2Bytes1 $ toInteger (getLabel labels end - getLabel labels start)] 74 | substituteLabel labs (PUSHLABEL name) = [PUSH $ integer2Bytes1 $ toInteger (getLabel labs name)] 75 | substituteLabel _ x = [x] 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /src/Blockchain/VM/VMState.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.VM.VMState ( 3 | VMState(..), 4 | Memory(..), 5 | startingState, 6 | VMException(..), 7 | DebugCallCreate(..), 8 | -- addErr 9 | -- getReturnValue 10 | ) where 11 | 12 | import Control.Monad 13 | import qualified Data.Vector.Storable.Mutable as V 14 | import qualified Data.ByteString as B 15 | import Data.IORef 16 | import Data.Word 17 | 18 | 19 | import Blockchain.Data.Address 20 | import Blockchain.Data.Code 21 | import Blockchain.Data.Log 22 | import Blockchain.ExtWord 23 | import Blockchain.Format 24 | import Blockchain.VM.Code 25 | import Blockchain.VM.Environment 26 | 27 | data VMException = 28 | OutOfGasException | 29 | StackTooSmallException | 30 | VMException String | 31 | MalformedOpcodeException | 32 | DivByZeroException | 33 | InsufficientFunds | 34 | AddressDoesNotExist | 35 | CallStackTooDeep | 36 | InvalidJump deriving (Show) 37 | 38 | data Memory = 39 | Memory { 40 | mVector::V.IOVector Word8, 41 | mSize::IORef Word256 42 | } 43 | 44 | 45 | newMemory::IO Memory 46 | newMemory = do 47 | arr <- V.new 100 48 | size <- newIORef 0 49 | forM_ [0..99] $ \p -> V.write arr p 0 50 | return $ Memory arr size 51 | 52 | data DebugCallCreate = 53 | DebugCallCreate { 54 | ccData::B.ByteString, 55 | ccDestination::Maybe Address, 56 | ccGasLimit::Integer, 57 | ccValue::Integer 58 | } deriving (Show, Eq) 59 | 60 | data VMState = 61 | VMState { 62 | vmGasRemaining::Integer, 63 | pc::Word256, 64 | memory::Memory, 65 | stack::[Word256], 66 | callDepth::Int, 67 | refund::Integer, 68 | 69 | suicideList::[Address], 70 | done::Bool, 71 | returnVal::Maybe B.ByteString, 72 | debugCallCreates::Maybe [DebugCallCreate], 73 | 74 | logs::[Log], 75 | 76 | environment::Environment, 77 | 78 | vmException::Maybe VMException 79 | } 80 | 81 | 82 | instance Format VMState where 83 | format state = 84 | "pc: " ++ show (pc state) ++ "\n" ++ 85 | "done: " ++ show (done state) ++ "\n" ++ 86 | "gasRemaining: " ++ show (vmGasRemaining state) ++ "\n" ++ 87 | "stack: " ++ show (stack state) ++ "\n" 88 | 89 | startingState::Environment->IO VMState 90 | startingState env = do 91 | m <- newMemory 92 | return VMState 93 | { 94 | pc = 0, 95 | done=False, 96 | returnVal=Nothing, 97 | vmException=Nothing, 98 | vmGasRemaining=0, 99 | stack=[], 100 | memory=m, 101 | callDepth=0, 102 | refund=0, 103 | logs=[], 104 | environment=env, 105 | debugCallCreates=Nothing, --only used for running ethereum tests 106 | suicideList=[] 107 | } 108 | 109 | {- 110 | getReturnValue::VMState->IO B.ByteString 111 | getReturnValue state = 112 | case stack state of 113 | [add, size] -> mLoadByteString (memory state) add size 114 | [] -> return B.empty --Happens when STOP is called 115 | --TODO- This needs better error handling other than to just crash if the stack isn't 2 items long 116 | _ -> error "Error in getReturnValue: VM ended with stack in an unsupported case" 117 | 118 | 119 | -} 120 | -------------------------------------------------------------------------------- /src/Blockchain/VM/OpcodePrices.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults #-} 2 | 3 | module Blockchain.VM.OpcodePrices where 4 | 5 | import Prelude hiding (EQ, LT, GT) 6 | 7 | import Blockchain.ExtWord 8 | import Blockchain.VM.Opcodes 9 | 10 | opGasPrice::Operation->Integer 11 | opGasPrice DUP1 = 3 12 | opGasPrice DUP2 = 3 13 | opGasPrice DUP3 = 3 14 | opGasPrice DUP4 = 3 15 | opGasPrice DUP5 = 3 16 | opGasPrice DUP6 = 3 17 | opGasPrice DUP7 = 3 18 | opGasPrice DUP8 = 3 19 | opGasPrice DUP9 = 3 20 | opGasPrice DUP10 = 3 21 | opGasPrice DUP11 = 3 22 | opGasPrice DUP12 = 3 23 | opGasPrice DUP13 = 3 24 | opGasPrice DUP14 = 3 25 | opGasPrice DUP15 = 3 26 | opGasPrice DUP16 = 3 27 | opGasPrice SWAP1 = 3 28 | opGasPrice SWAP2 = 3 29 | opGasPrice SWAP3 = 3 30 | opGasPrice SWAP4 = 3 31 | opGasPrice SWAP5 = 3 32 | opGasPrice SWAP6 = 3 33 | opGasPrice SWAP7 = 3 34 | opGasPrice SWAP8 = 3 35 | opGasPrice SWAP9 = 3 36 | opGasPrice SWAP10 = 3 37 | opGasPrice SWAP11 = 3 38 | opGasPrice SWAP12 = 3 39 | opGasPrice SWAP13 = 3 40 | opGasPrice SWAP14 = 3 41 | opGasPrice SWAP15 = 3 42 | opGasPrice SWAP16 = 3 43 | opGasPrice (PUSH _) = 3 44 | opGasPrice ADD = 3 45 | opGasPrice MUL = 5 46 | opGasPrice SUB = 3 47 | opGasPrice DIV = 5 48 | opGasPrice SDIV = 5 49 | opGasPrice MOD = 5 50 | opGasPrice SMOD = 5 51 | opGasPrice ADDMOD = 8 52 | opGasPrice MULMOD = 8 53 | opGasPrice SIGNEXTEND = 5 54 | opGasPrice LT = 3 55 | opGasPrice GT = 3 56 | opGasPrice SLT = 3 57 | opGasPrice SGT = 3 58 | opGasPrice EQ = 3 59 | opGasPrice ISZERO = 3 60 | opGasPrice AND = 3 61 | opGasPrice OR = 3 62 | opGasPrice XOR = 3 63 | opGasPrice NOT = 3 64 | opGasPrice BYTE = 3 65 | opGasPrice ADDRESS = 2 66 | opGasPrice BALANCE = 20 67 | opGasPrice ORIGIN = 2 68 | opGasPrice CALLER = 2 69 | opGasPrice CALLVALUE = 2 70 | opGasPrice CALLDATALOAD = 3 71 | opGasPrice CALLDATASIZE = 2 72 | opGasPrice CODESIZE = 2 73 | opGasPrice GASPRICE = 2 74 | opGasPrice EXTCODESIZE = 20 75 | opGasPrice BLOCKHASH = 20 76 | opGasPrice COINBASE = 2 77 | opGasPrice TIMESTAMP = 2 78 | opGasPrice NUMBER = 2 79 | opGasPrice DIFFICULTY = 2 80 | opGasPrice GASLIMIT = 2 81 | opGasPrice POP = 2 82 | opGasPrice MLOAD = 3 83 | opGasPrice MSTORE = 3 84 | opGasPrice MSTORE8 = 3 85 | opGasPrice SLOAD = 50 86 | opGasPrice JUMP = 8 87 | opGasPrice JUMPI = 10 88 | opGasPrice PC = 2 89 | opGasPrice MSIZE = 2 90 | opGasPrice GAS = 2 91 | opGasPrice JUMPDEST = 1 92 | opGasPrice CREATE = 32000 93 | opGasPrice CALLCODE = 40 94 | opGasPrice RETURN = 0 95 | opGasPrice STOP = 0 96 | opGasPrice SUICIDE = 0 97 | 98 | opGasPrice (MalformedOpcode _) = 0 --gonna fail anyway, just put something arbitrary here 99 | 100 | opGasPrice x = error $ "Missing opcode in opCodePrice: " ++ show x 101 | 102 | 103 | 104 | 105 | 106 | 107 | gTX = 21000 108 | gTXDATANONZERO = 68 109 | gTXDATAZERO = 4 110 | 111 | 112 | gMEMWORD = 3 113 | gQUADCOEFFDIV = 512 114 | 115 | 116 | gEXPBASE = 10 117 | gEXPBYTE = 10 118 | 119 | gCALLDATACOPYBASE = 3 120 | 121 | gCODECOPYBASE = 3 122 | gEXTCODECOPYBASE = 20 123 | gCOPYWORD = 3 124 | 125 | 126 | gLOG = 375 127 | gLOGTOPIC = 375 128 | gLOGDATA = 8 129 | 130 | gCALL = 40 131 | gCALLVALUETRANSFER = 9000::Word256 132 | gCALLSTIPEND = 2300::Word256 133 | gCALLNEWACCOUNT = 25000::Word256 134 | 135 | gCREATEDATA = 200 136 | 137 | 138 | 139 | gSHA3BASE = 30 140 | gSHA3WORD = 6 141 | gECRECOVER = 3000 142 | gSHA256BASE = 60 143 | gSHA256WORD = 12 144 | gRIPEMD160BASE = 600 145 | gRIPEMD160WORD = 120 146 | gIDENTITYBASE = 15 147 | gIDENTITYWORD = 3 148 | -------------------------------------------------------------------------------- /fastNonceFinder/nonceFinder.c: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | #include "sha3.h" 11 | 12 | #define NUMTHREADS 8 13 | 14 | pthread_mutex_t mutex = PTHREAD_MUTEX_INITIALIZER; 15 | 16 | uint8_t savedNonce[32]; 17 | volatile bool nonceFound; 18 | 19 | void saveNonce(uint8_t *val) { 20 | 21 | pthread_mutex_lock(&mutex); 22 | 23 | if (nonceFound) return; //Too late, you've been beaten to it 24 | 25 | memcpy(savedNonce, val, 32); 26 | 27 | nonceFound=true; 28 | 29 | pthread_mutex_unlock(&mutex); 30 | 31 | } 32 | 33 | struct ThreadData { 34 | int thread_num; 35 | uint8_t data[32]; 36 | uint8_t threshold[32]; 37 | }; 38 | 39 | void getHash(uint8_t *in, uint8_t *out) { 40 | struct sha3_ctx ctx; 41 | sha3_init(&ctx, 256); 42 | sha3_update(&ctx, in, 64); 43 | sha3_finalize(&ctx, out); 44 | } 45 | 46 | int compare256(uint8_t first[32], uint8_t second[32]) { 47 | int i; 48 | for(i = 0; i < 32; i++) { 49 | if (first[i] < second[i]) return -1; 50 | else if (first[i] > second[i]) return 1; 51 | } 52 | return 0; 53 | } 54 | 55 | void increment256(uint8_t val[32]) { 56 | int i; 57 | for(i=31; i >= 0; i--) { 58 | val[i]++; 59 | if (val[i] != 0) return; 60 | } 61 | } 62 | 63 | void print256(uint8_t val[32]) { 64 | int i; 65 | for(i = 0; i < 32; i++) 66 | printf("%02x", val[i]); 67 | printf("\n"); 68 | } 69 | 70 | void *calculateHashes(void *x) { 71 | uint8_t dataAndNonce[64] = {0}; 72 | uint8_t out[32]; 73 | 74 | struct ThreadData *threadData = (struct ThreadData *) x; 75 | 76 | printf("%d, #### starting thread\n", threadData->thread_num); 77 | 78 | 79 | memcpy(dataAndNonce, threadData->data, 32); 80 | 81 | uint64_t i; 82 | 83 | 84 | *(dataAndNonce + 32) = threadData->thread_num; 85 | while(true){ 86 | //No mutex needed, because this is just a bool, it is only flipped to true in one place, and 87 | //even if I read while writing, the worst case is that I calculate one extra sha hash. 88 | if (nonceFound) return NULL; 89 | increment256(dataAndNonce+32); 90 | getHash(dataAndNonce, out); 91 | if (compare256(out, threadData->threshold) == -1) { 92 | printf("data: "); 93 | print256(dataAndNonce); 94 | printf("nonce: "); 95 | print256(dataAndNonce+32); 96 | printf("out: "); 97 | print256(out); 98 | printf("done\n"); 99 | saveNonce(dataAndNonce+32); 100 | return NULL; 101 | } 102 | } 103 | 104 | printf("shouldn't be here\n"); 105 | 106 | exit(1); 107 | } 108 | 109 | int findNonce(uint8_t data[32], uint8_t threshold[32], uint8_t *out) { 110 | pthread_t inc_x_thread[NUMTHREADS]; 111 | struct ThreadData threadData[NUMTHREADS]; 112 | 113 | printf("data: "); 114 | print256(data); 115 | printf("threshold: "); 116 | print256(threshold); 117 | 118 | int thread_num; 119 | 120 | int i; 121 | 122 | nonceFound=false; 123 | 124 | for(thread_num = 0; thread_num < NUMTHREADS-1; thread_num++) { 125 | 126 | memcpy(threadData[thread_num].threshold, threshold, 32); 127 | memcpy(threadData[thread_num].data, data, 32); 128 | threadData[thread_num].thread_num = thread_num; 129 | 130 | if(pthread_create(&inc_x_thread[thread_num], NULL, calculateHashes, (threadData+thread_num))) { 131 | fprintf(stderr, "Error creating thread\n"); 132 | return 1; 133 | } 134 | } 135 | 136 | for(thread_num = 0; thread_num < NUMTHREADS-1; thread_num++) { 137 | if(pthread_join(inc_x_thread[thread_num], NULL)) { 138 | fprintf(stderr, "Error joining thread\n"); 139 | return 2; 140 | } 141 | } 142 | 143 | assert(nonceFound); 144 | 145 | printf("savedNonce: "); 146 | print256(savedNonce); 147 | 148 | memcpy(out, savedNonce, 32); 149 | 150 | return 0; 151 | 152 | } 153 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | 2 | The blockchain is the underlying technology behind Bitcoin.... But, blockchain technology goes way beyond just being an "online currency". The 3 | blockchain is a distributed system which can be used to verify and guarantee stated claims (account balance, resource ownership, legal contracts, 4 | etc). The Ethereum blockchain allows Turing Complete code snippets to run on a blockchain, giving the user the fullest leeway to experiment 5 | with all imagined functionality. (see http://ethereum.org for more info). 6 | 7 | This package provides a tool written in Haskell to allow you to connect to the Ethereum blockchain (see http://gavwood.com/paper.pdf for detail 8 | of how this works). You can install the tool as follows 9 | 10 | > cabal install ethereum-client-haskell 11 | 12 | and run it as follows 13 | 14 | > ethereumH 15 | 16 | This is a first release, and should still be considered as a sort of alpha (albeit, almost fully working), in part because the Ethereum spec 17 | itself is still a moving target. That being said, once you run the program, the client will connect to the current testnet and start receiving 18 | and processing blocks (which you will soon see as a series of fast moving messages up the screen). 19 | 20 | If you look at the messages, you will see that.... 21 | 22 | - The client is downloading all the blocks from the testnet. 23 | - Transactions are being processed, and balances are being updated. 24 | - Transactions with code are being run in the Ethereum virtual machine (the code for the VM is in Blockchain.VM.*). 25 | - Once the client has loaded all the blocks, it will start to mine. 26 | 27 | If you fiddle with the source code, you can additionally.... 28 | 29 | - Submit basic transactions. 30 | - Write Ethereum code snippets (which you can write using a specially crafted DSL, which can be compiled to VM code). 31 | - Experiment with which peer-to-peer network to connect to. 32 | 33 | I've included a sample private key to get things started (which is, of course, not going to ever be used by me in the real world :) ). You might 34 | want to change that before you do any serious work. 35 | 36 | ---------- 37 | 38 | Things are moving fast in the Ethereum world, and the testnet is an evolving beast.... I haven't written any code to seriously deal with peer 39 | discovery yet, and have just put in a bunch of hardcoded ip addresses (with one that I know is working today, anointed as the default). If 40 | you find that you can't connect to the testnet, you might want to play with the hardcoded addresses in the Blockchain.PeerUrls module. You can 41 | find current peer ip addresses at 42 | 43 | http://ethergit.com (click the "network peers" link). 44 | 45 | You can choose peers other than the default by supplying a parameter to the ethereumH program. 46 | 47 | > ethereum 4 48 | 49 | (where the param is an index in the hardcoded list.... to select the entry). 50 | 51 | ---------- 52 | 53 | Known Problems: 54 | 55 | - The program is still single threaded, so mining and block synchronization all happen sequentially.... This means that once mining starts, it 56 | will block until done (even after another peer may have succeeded). To give the client a chance to load all the new data, mining only is initiated 57 | every other block right now (ie- block 1, mine, block2 synch, block3 mine, etc). 58 | 59 | - The VM code needs a bit more testing.... It works pretty well, but every once and a while, a split in the chain (relative to the other 60 | clients) occurs. To detect these problems, I deliberately end the program when this happens.... This sort of looks like a crash, but the ides is 61 | that by forcing me to deal with these issues immediately, all such problems will be purged. 62 | 63 | - I don't support the Whisper protocol at all yet. 64 | 65 | - I can't mine a block with the new logging mechanism (although I can synch against other peer mined blocks, so this isn't as bad as it sounds 66 | right now). 67 | 68 | - You still need to fiddle with source code to submit a transaction (although this might be considered a feature.... since the Ethereum code 69 | is compiled from a Haskell DSL language, and is fully type checked at compile time). 70 | 71 | - As mentioned above, the Ethereum network is changing very fast, so what works today might not work tomorrow.... 72 | 73 | 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /src/Blockchain/BlockSynchronizer.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.BlockSynchronizer ( 3 | handleNewBlockHashes, 4 | handleNewBlocks 5 | ) where 6 | 7 | import Control.Monad.IO.Class 8 | import Control.Monad.State 9 | import qualified Data.Binary as Bin 10 | import qualified Data.ByteString as B 11 | import qualified Data.ByteString.Lazy as BL 12 | import Data.Function 13 | import Data.List 14 | import Data.Maybe 15 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 16 | 17 | import Blockchain.BlockChain 18 | import qualified Blockchain.Colors as CL 19 | import Blockchain.Communication 20 | import Blockchain.Context 21 | import Blockchain.Data.BlockDB 22 | import Blockchain.Data.DataDefs 23 | import Blockchain.Data.RLP 24 | import Blockchain.Data.Wire 25 | import Blockchain.DBM 26 | import Blockchain.ExtDBs 27 | import Blockchain.Frame 28 | import Blockchain.SHA 29 | 30 | --import Debug.Trace 31 | 32 | data GetBlockHashesResult = NeedMore SHA | NeededHashes [SHA] deriving (Show) 33 | 34 | --Only use for debug purposes, to trick the peer to rerun VM code for a particular block 35 | debug_blockDBGet::B.ByteString->DBM (Maybe B.ByteString) 36 | debug_blockDBGet hash = do 37 | maybeBlockBytes <- blockDBGet hash 38 | case maybeBlockBytes of 39 | Nothing -> return Nothing 40 | Just blockBytes -> do 41 | let theBlock = rlpDecode . rlpDeserialize $ blockBytes 42 | if blockDataNumber (blockBlockData theBlock) > 99263 43 | then return Nothing 44 | else return maybeBlockBytes 45 | 46 | 47 | findFirstHashAlreadyInDB::[SHA]->ContextM (Maybe SHA) 48 | findFirstHashAlreadyInDB hashes = do 49 | items <- lift $ filterM (fmap (not . isNothing) . blockDBGet . BL.toStrict . Bin.encode) hashes 50 | --items <- lift $ filterM (fmap (not . isNothing) . debug_blockDBGet . BL.toStrict . Bin.encode) hashes 51 | return $ safeHead items 52 | where 53 | safeHead::[a]->Maybe a 54 | safeHead [] = Nothing 55 | safeHead (x:_) = Just x 56 | 57 | handleNewBlockHashes::[SHA]->EthCryptM ContextM () 58 | --handleNewBlockHashes _ list | trace ("########### handleNewBlockHashes: " ++ show list) $ False = undefined 59 | handleNewBlockHashes [] = return () --error "handleNewBlockHashes called with empty list" 60 | handleNewBlockHashes blockHashes = do 61 | result <- lift $ findFirstHashAlreadyInDB blockHashes 62 | case result of 63 | Nothing -> do 64 | --liftIO $ putStrLn "Requesting more block hashes" 65 | cxt <- lift get 66 | lift $ put cxt{neededBlockHashes=reverse blockHashes ++ neededBlockHashes cxt} 67 | sendMsg $ GetBlockHashes [last blockHashes] 0x500 68 | Just hashInDB -> do 69 | liftIO $ putStrLn $ "Found a serverblock already in our database: " ++ show (pretty hashInDB) 70 | cxt <- lift get 71 | --liftIO $ putStrLn $ show (pretty blockHashes) 72 | lift $ put cxt{neededBlockHashes=reverse (takeWhile (/= hashInDB) blockHashes) ++ neededBlockHashes cxt} 73 | askForSomeBlocks 74 | 75 | askForSomeBlocks::EthCryptM ContextM () 76 | askForSomeBlocks = do 77 | cxt <- lift get 78 | if null (neededBlockHashes cxt) 79 | then return () 80 | else do 81 | let (firstBlocks, lastBlocks) = splitAt 128 (neededBlockHashes cxt) 82 | lift $ put cxt{neededBlockHashes=lastBlocks} 83 | sendMsg $ GetBlocks firstBlocks 84 | 85 | 86 | handleNewBlocks::[Block]->EthCryptM ContextM () 87 | handleNewBlocks [] = error "handleNewBlocks called with empty block list" 88 | handleNewBlocks blocks = do 89 | let orderedBlocks = 90 | sortBy (compare `on` blockDataNumber . blockBlockData) blocks 91 | 92 | maybeParentBlock <- lift $ lift $ getBlock (blockDataParentHash $ blockBlockData $ head $ orderedBlocks) --head OK, [] weeded out 93 | 94 | cxt <- lift get 95 | 96 | case (neededBlockHashes cxt, maybeParentBlock) of 97 | ([], Nothing) -> do 98 | liftIO $ putStrLn $ CL.red $ "Resynching!!!!!!!!" 99 | handleNewBlockHashes [blockHash $ head orderedBlocks] -- head OK, [] weeded out 100 | (_, Nothing) -> 101 | liftIO $ putStrLn $ CL.red "Warning: a new block has arrived before another block sync is in progress. This block will be thrown away for now, and re-requested later." 102 | (_, Just _) -> do 103 | liftIO $ putStrLn "Submitting new blocks" 104 | lift $ addBlocks False $ sortBy (compare `on` blockDataNumber . blockBlockData) blocks 105 | liftIO $ putStrLn $ show (length blocks) ++ " blocks have been submitted" 106 | askForSomeBlocks 107 | -------------------------------------------------------------------------------- /ethereum-client-haskell.cabal: -------------------------------------------------------------------------------- 1 | name: ethereum-client-haskell 2 | version: 0.0.4 3 | cabal-version: >=1.10 4 | build-type: Simple 5 | author: Jamshid 6 | license-file: LICENSE 7 | maintainer: jamshidnh@gmail.com 8 | synopsis: A Haskell version of an Ethereum client 9 | extra-source-files: 10 | fastNonceFinder/bitfn.h 11 | fastNonceFinder/sha3.c 12 | fastNonceFinder/sha3.h 13 | category: Data Structures 14 | license: BSD3 15 | description: 16 | The client described in the Ethereum Yellowpaper 17 | 18 | source-repository this 19 | type: git 20 | location: https://github.com/jamshidh/ethereum-client-haskell 21 | branch: master 22 | tag: v0.0.4 23 | 24 | executable ethereumH 25 | default-language: Haskell98 26 | build-depends: 27 | base >= 4 && < 5 28 | , base16-bytestring 29 | , binary 30 | , bytestring 31 | , containers 32 | , cryptohash 33 | , crypto-pubkey 34 | , crypto-pubkey-types 35 | , crypto-random 36 | , data-default 37 | , directory 38 | , either 39 | , entropy 40 | , ethereum-data-sql 41 | , ethereum-encryption 42 | , ethereum-merkle-patricia-db 43 | , ethereum-rlp 44 | , ethereum-util 45 | , filepath 46 | , haskoin 47 | , hminer 48 | , leveldb-haskell 49 | , mmap 50 | , mtl 51 | , network 52 | , nibblestring 53 | , resourcet 54 | , SHA2 55 | , time 56 | , transformers 57 | , vector 58 | , ansi-wl-pprint 59 | , ethereum-client-haskell 60 | main-is: Main.hs 61 | C-sources: fastNonceFinder/nonceFinder.c 62 | ghc-options: -Wall -O2 63 | buildable: True 64 | hs-source-dirs: exec_src 65 | 66 | library 67 | default-language: Haskell98 68 | build-depends: 69 | base >= 4 && < 5 70 | , array 71 | , base16-bytestring 72 | , binary 73 | , bytestring 74 | , containers 75 | , cryptohash 76 | , crypto-pubkey-types 77 | , data-default 78 | , directory 79 | , either 80 | , entropy 81 | , ethereum-data-sql 82 | , ethereum-encryption 83 | , ethereum-merkle-patricia-db 84 | , ethereum-rlp 85 | , ethereum-util 86 | , filepath 87 | , haskoin 88 | , hminer 89 | , IfElse 90 | , leveldb-haskell 91 | , mtl 92 | , mmap 93 | , network 94 | , nibblestring 95 | , resourcet 96 | , SHA2 97 | , time 98 | , transformers 99 | , vector 100 | , ansi-wl-pprint 101 | exposed-modules: 102 | Blockchain.BlockChain 103 | Blockchain.BlockSynchronizer 104 | Blockchain.Communication 105 | Blockchain.Context 106 | Blockchain.Data.GenesisBlock 107 | Blockchain.Data.Peer 108 | -- Blockchain.Data.TransactionReceipt 109 | Blockchain.Data.Wire 110 | Blockchain.DB.ModifyStateDB 111 | Blockchain.Display 112 | Blockchain.JCommand 113 | Blockchain.Mining 114 | Blockchain.PeerUrls 115 | Blockchain.SampleTransactions 116 | Blockchain.VM.Code 117 | Blockchain.VM.Environment 118 | Blockchain.VM.Labels 119 | Blockchain.VM.Memory 120 | Blockchain.VM.Opcodes 121 | Blockchain.VM.OpcodePrices 122 | Blockchain.VM.PrecompiledContracts 123 | Blockchain.VM.VMM 124 | Blockchain.VM.VMState 125 | Blockchain.VM 126 | C-sources: fastNonceFinder/nonceFinder.c 127 | ghc-options: -Wall -O2 128 | buildable: True 129 | hs-source-dirs: src 130 | 131 | Test-Suite test-ethereumH 132 | default-language: Haskell98 133 | type: exitcode-stdio-1.0 134 | main-is: Main.hs 135 | hs-source-dirs: test, src 136 | build-depends: base >= 4 && < 5 137 | , test-framework 138 | , test-framework-hunit 139 | , HUnit 140 | , containers -------------------------------------------------------------------------------- /src/Blockchain/JCommand.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.JCommand ( 3 | JCommand(..), 4 | Storage(..), 5 | Word(..), 6 | JBool(..), 7 | jcompile 8 | ) where 9 | 10 | import Prelude hiding (LT, GT, EQ) 11 | 12 | import Control.Applicative 13 | import Control.Monad 14 | 15 | import Blockchain.Data.Code 16 | import Blockchain.Util 17 | import Blockchain.VM.Opcodes 18 | 19 | import Blockchain.ExtWord 20 | 21 | data Storage = PermStorage Word | MemStorage Word deriving (Show) 22 | 23 | data Word = 24 | Number Word256 | 25 | TheAddress | 26 | Origin | 27 | Caller | 28 | CallDataSize | 29 | Input Word | 30 | PermVal Word | 31 | MemVal Word | 32 | Abs Word | 33 | Word :+: Word | Word :-: Word | Word :*: Word | Neg Word | Signum Word deriving (Show) 34 | 35 | data JBool = JTrue | JFalse | 36 | Word :==: Word | 37 | Word :>: Word | 38 | Word :<: Word | 39 | Word :>=: Word | 40 | Word :<=: Word 41 | deriving (Show) 42 | 43 | instance Num Word where 44 | fromInteger x = Number $ fromInteger x 45 | Number x + Number y = Number $ x+y 46 | x + y = x :+: y 47 | x - y = x :-: y 48 | Number x * Number y = Number $ x*y 49 | x * y = x :*: y 50 | abs (Number x) = Number $ abs x 51 | abs x = Abs x 52 | negate (Number x) = Number (-x) 53 | negate x = Neg x 54 | 55 | signum (Number x) = Number (signum x) 56 | signum x = Signum x 57 | 58 | 59 | data JCommand = Storage :=: Word | 60 | If JBool [JCommand] | 61 | While JBool [JCommand] | 62 | ReturnCode Code deriving (Show) 63 | 64 | infixl 6 :+: 65 | infixl 5 :-: 66 | infixl 4 :=: 67 | 68 | 69 | j::[JCommand]->Unique [Operation] 70 | j x = fmap concat $ sequence $ jCommand2Op <$> x 71 | 72 | jcompile::[JCommand]->(Int, [Operation]) 73 | jcompile x = runUnique (j x) 0 74 | 75 | data Unique a = Unique { runUnique::Int->(Int, a) } 76 | 77 | instance Functor Unique where 78 | fmap = liftM 79 | 80 | instance Applicative Unique where 81 | pure = return 82 | (<*>) = ap 83 | 84 | instance Monad Unique where 85 | (Unique runner) >>= f = Unique $ \val -> let (val', x') = runner val 86 | Unique g = f x' 87 | in g val' 88 | return x = Unique $ \val -> (val, x) 89 | 90 | getUnique::String->Unique String 91 | getUnique s = Unique $ \val -> (val+1, s ++ show val) 92 | 93 | pushVal::Word->[Operation] 94 | pushVal (Number x) = [PUSH $ integer2Bytes1 $ toInteger x] 95 | pushVal TheAddress = [ADDRESS] 96 | pushVal Caller = [CALLER] 97 | pushVal CallDataSize = [CALLDATASIZE] 98 | pushVal Origin = [ORIGIN] 99 | pushVal (Input x) = pushVal x ++ [CALLDATALOAD] 100 | pushVal (PermVal x) = pushVal x ++ [SLOAD] 101 | pushVal (MemVal x) = pushVal x ++ [MLOAD] 102 | pushVal (x :+: y) = pushVal y ++ pushVal x ++ [ADD] 103 | pushVal (x :-: y) = pushVal y ++ pushVal x ++ [SUB] 104 | pushVal (x :*: y) = pushVal y ++ pushVal x ++ [MUL] 105 | pushVal (Abs x) = pushVal x ++ pushVal (Signum x) ++ [MUL] 106 | pushVal (Signum x) = pushVal x ++ pushVal (Number 0) ++ [GT] ++ pushVal x ++ pushVal (Number 0) ++ [LT, SUB] 107 | pushVal (Neg x) = pushVal x ++ [NEG] 108 | 109 | pushBoolVal::JBool->[Operation] 110 | pushBoolVal (x :==: y) = pushVal y ++ pushVal x ++ [EQ] 111 | pushBoolVal (x :>: y) = pushVal y ++ pushVal x ++ [GT] 112 | pushBoolVal (x :<: y) = pushVal y ++ pushVal x ++ [LT] 113 | pushBoolVal (x :>=: y) = pushVal y ++ pushVal x ++ [ISZERO, LT] 114 | pushBoolVal (x :<=: y) = pushVal y ++ pushVal x ++ [ISZERO, GT] 115 | pushBoolVal JTrue = [PUSH [1]] 116 | pushBoolVal JFalse = [PUSH [0]] 117 | 118 | jCommand2Op::JCommand->Unique [Operation] 119 | jCommand2Op (PermStorage sPosition :=: val) = 120 | return $ pushVal val ++ pushVal sPosition ++ [SSTORE] 121 | jCommand2Op (MemStorage sPosition :=: val) = 122 | return $ pushVal val ++ pushVal sPosition ++ [MSTORE] 123 | jCommand2Op (If cond code) = do 124 | after <- getUnique "after" 125 | compiledCode <- j code 126 | return $ pushBoolVal cond ++ [ISZERO, PUSHLABEL after, JUMPI] ++ compiledCode ++ [LABEL after] 127 | jCommand2Op (While cond code) = do 128 | after <- getUnique "after" 129 | before <- getUnique "before" 130 | compiledCode <- j code 131 | return $ [LABEL before] ++ pushBoolVal cond ++ [ISZERO, PUSHLABEL after, JUMPI] ++ compiledCode ++ [PUSHLABEL before, JUMP] ++ [LABEL after] 132 | jCommand2Op (ReturnCode (Code codeBytes')) = do 133 | codeBegin <- getUnique "begin" 134 | codeEnd <- getUnique "end" 135 | return $ 136 | [ 137 | PUSHDIFF codeBegin codeEnd, 138 | PUSHLABEL codeBegin, 139 | PUSH [0], 140 | CODECOPY, 141 | PUSHDIFF codeBegin codeEnd, 142 | PUSH [0], 143 | RETURN 144 | ] 145 | ++ [LABEL codeBegin, DATA codeBytes', LABEL codeEnd] 146 | -------------------------------------------------------------------------------- /src/Blockchain/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Blockchain.Context ( 4 | Context(..), 5 | ContextM, 6 | isDebugEnabled, 7 | getStorageKeyVal', 8 | getAllStorageKeyVals', 9 | getDebugMsg, 10 | addDebugMsg, 11 | clearDebugMsg, 12 | putStorageKeyVal', 13 | deleteStorageKey', 14 | incrementNonce, 15 | getNewAddress 16 | ) where 17 | 18 | 19 | import Control.Monad.IfElse 20 | import Control.Monad.IO.Class 21 | import Control.Monad.State 22 | import Control.Monad.Trans.Resource 23 | import qualified Data.ByteString as B 24 | import qualified Data.NibbleString as N 25 | import qualified Data.Vector as V 26 | import System.Directory 27 | import System.FilePath 28 | import System.IO 29 | import System.IO.MMap 30 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), ()) 31 | 32 | import Blockchain.Constants 33 | import Blockchain.DBM 34 | import Blockchain.Data.Peer 35 | import Blockchain.Data.Address 36 | import Blockchain.Data.AddressStateDB 37 | import Blockchain.Data.DataDefs 38 | import Blockchain.Data.RLP 39 | import qualified Blockchain.Database.MerklePatricia as MPDB 40 | import qualified Blockchain.Database.MerklePatricia.Internal as MPDB 41 | import Blockchain.ExtDBs 42 | import Blockchain.ExtWord 43 | import Blockchain.SHA 44 | import Blockchain.Util 45 | import Cache 46 | import Constants 47 | import qualified Data.NibbleString as N 48 | 49 | --import Debug.Trace 50 | 51 | data Context = 52 | Context { 53 | neededBlockHashes::[SHA], 54 | pingCount::Int, 55 | peers::[Peer], 56 | miningDataset::B.ByteString, 57 | useAlternateGenesisBlock::Bool, 58 | vmTrace::[String], 59 | debugEnabled::Bool 60 | } 61 | 62 | type ContextM = StateT Context DBM 63 | 64 | isDebugEnabled::ContextM Bool 65 | isDebugEnabled = do 66 | cxt <- get 67 | return $ debugEnabled cxt 68 | 69 | {- 70 | initContext::String->IO Context 71 | initContext theType = do 72 | liftIO $ putStr "Loading mining cache.... " 73 | hFlush stdout 74 | dataset <- return "" -- mmapFileByteString "dataset0" Nothing 75 | liftIO $ putStrLn "Finished" 76 | homeDir <- getHomeDirectory 77 | createDirectoryIfMissing False $ homeDir dbDir theType 78 | return $ Context 79 | [] 80 | 0 81 | [] 82 | dataset 83 | False 84 | -} 85 | 86 | getStorageKeyVal'::Address->Word256->ContextM Word256 87 | getStorageKeyVal' owner key = do 88 | addressState <- lift $ getAddressState owner 89 | dbs <- lift get 90 | let mpdb = (stateDB dbs){MPDB.stateRoot=addressStateContractRoot addressState} 91 | maybeVal <- lift $ lift $ MPDB.getKeyVal mpdb (N.pack $ (N.byte2Nibbles =<<) $ word256ToBytes key) 92 | case maybeVal of 93 | Nothing -> return 0 94 | Just x -> return $ fromInteger $ rlpDecode $ rlpDeserialize $ rlpDecode x 95 | 96 | getAllStorageKeyVals'::Address->ContextM [(MPDB.Key, Word256)] 97 | getAllStorageKeyVals' owner = do 98 | addressState <- lift $ getAddressState owner 99 | dbs <- lift get 100 | let mpdb = (stateDB dbs){MPDB.stateRoot=addressStateContractRoot addressState} 101 | kvs <- lift $ lift $ MPDB.unsafeGetAllKeyVals mpdb 102 | return $ map (fmap $ fromInteger . rlpDecode . rlpDeserialize . rlpDecode) kvs 103 | 104 | getDebugMsg::ContextM String 105 | getDebugMsg = do 106 | cxt <- get 107 | return $ concat $ reverse $ vmTrace cxt 108 | 109 | addDebugMsg::String->ContextM () 110 | addDebugMsg msg = do 111 | cxt <- get 112 | put cxt{vmTrace=msg:vmTrace cxt} 113 | 114 | clearDebugMsg::ContextM () 115 | clearDebugMsg = do 116 | cxt <- get 117 | put cxt{vmTrace=[]} 118 | 119 | putStorageKeyVal'::Address->Word256->Word256->ContextM () 120 | putStorageKeyVal' owner key val = do 121 | lift $ hashDBPut storageKeyNibbles 122 | addressState <- lift $ getAddressState owner 123 | dbs <- lift get 124 | let mpdb = (stateDB dbs){MPDB.stateRoot=addressStateContractRoot addressState} 125 | newContractRoot <- fmap MPDB.stateRoot $ lift $ lift $ MPDB.putKeyVal mpdb storageKeyNibbles (rlpEncode $ rlpSerialize $ rlpEncode $ toInteger val) 126 | lift $ putAddressState owner addressState{addressStateContractRoot=newContractRoot} 127 | where storageKeyNibbles = N.pack $ (N.byte2Nibbles =<<) $ word256ToBytes key 128 | 129 | deleteStorageKey'::Address->Word256->ContextM () 130 | deleteStorageKey' owner key = do 131 | addressState <- lift $ getAddressState owner 132 | dbs <- lift get 133 | let mpdb = (stateDB dbs){MPDB.stateRoot=addressStateContractRoot addressState} 134 | newContractRoot <- fmap MPDB.stateRoot $ lift $ lift $ MPDB.deleteKey mpdb (N.pack $ (N.byte2Nibbles =<<) $ word256ToBytes key) 135 | lift $ putAddressState owner addressState{addressStateContractRoot=newContractRoot} 136 | 137 | incrementNonce::Address->ContextM () 138 | incrementNonce address = do 139 | addressState <- lift $ getAddressState address 140 | lift $ putAddressState address addressState{ addressStateNonce = addressStateNonce addressState + 1 } 141 | 142 | getNewAddress::Address->ContextM Address 143 | getNewAddress address = do 144 | addressState <- lift $ getAddressState address 145 | whenM isDebugEnabled $ liftIO $ putStrLn $ "Creating new account: owner=" ++ show (pretty address) ++ ", nonce=" ++ show (addressStateNonce addressState) 146 | let newAddress = getNewAddress_unsafe address (addressStateNonce addressState) 147 | incrementNonce address 148 | return newAddress 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | -------------------------------------------------------------------------------- /src/Blockchain/PeerUrls.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.PeerUrls where 3 | 4 | import Network 5 | 6 | -- Working 0, 1, 2, 67, 119 7 | 8 | ipAddresses::[(String, PortNumber)] 9 | ipAddresses = 10 | [ 11 | ("127.0.0.1", 30303), 12 | ("poc-9.ethdev.com", 30303), 13 | ("poc-8.ethdev.com", 30303), 14 | ("api.blockapps.net", 30303), 15 | ("stablenet.blockapps.net", 30303), 16 | ("gav.ethdev.com", 30303), 17 | ("52.5.60.7", 30303), 18 | ("52.4.40.229", 30303), 19 | ("52.4.180.23", 30303), 20 | ("52.4.131.128", 30303), 21 | ("52.16.188.185", 30303), 22 | ("52.0.243.36", 30303), 23 | ("92.51.165.126", 30303), 24 | ("144.76.62.101", 30303), 25 | ("52.5.26.21", 30303), 26 | ("52.5.26.15", 30303), 27 | ("52.5.25.137", 30303), 28 | ("54.207.93.166", 30303), 29 | 30 | ("207.12.89.180", 30303), 31 | ("24.90.136.85", 40404), 32 | ("185.43.109.23", 30303), 33 | ("76.220.27.23", 30303), 34 | ("194.151.205.61", 30303), 35 | ("104.236.44.20", 30303), 36 | ("90.215.69.132", 30303), 37 | ("46.115.170.122", 30303), 38 | ("82.113.99.187", 30303), 39 | ("54.73.114.158", 30303), 40 | ("94.197.120.233", 30303), 41 | ("99.36.164.218", 30301), 42 | ("79.205.230.196", 30303), 43 | ("213.61.84.226", 30303), 44 | ("82.217.72.169", 20818), 45 | ("66.91.18.59", 30303), 46 | ("92.225.49.139", 30303), 47 | ("46.126.19.53", 30303), 48 | ("209.6.197.196", 30303), 49 | ("95.91.196.230", 30303), 50 | ("77.87.49.7", 30303), 51 | ("77.50.138.143", 22228), 52 | ("84.232.211.95", 30300), 53 | ("213.127.159.150", 30303), 54 | ("89.71.42.180", 30303), 55 | ("216.240.30.23", 30303), 56 | ("62.163.114.115", 30304), 57 | ("178.198.11.18", 30303), 58 | ("94.117.148.121", 30303), 59 | ("80.185.182.157", 30303), 60 | ("129.194.71.126", 30303), 61 | ("129.194.71.126", 12667), 62 | ("199.254.238.167", 30303), 63 | ("71.208.244.211", 30303), 64 | ("46.114.45.182", 30303), 65 | ("178.37.149.29", 30303), 66 | ("81.38.156.153", 30303), 67 | ("5.144.60.120", 30304), 68 | ("67.188.113.229", 30303), 69 | ("23.121.237.24", 30303), 70 | ("37.120.31.241", 30303), 71 | ("79.178.55.18", 30303), 72 | ("50.1.116.44", 30303), 73 | ("213.129.230.10", 30303), 74 | ("91.64.116.234", 30303), 75 | ("86.164.51.215", 30303), 76 | ("46.127.142.224", 30300), 77 | ("195.221.66.4", 30300), 78 | ("95.90.239.241", 30303), 79 | ("176.67.169.137", 30303), 80 | ("94.224.199.123", 30303), 81 | ("38.117.159.162", 30303), 82 | ("5.9.141.240", 30303), 83 | ("110.164.236.93", 30303), 84 | ("86.147.58.164", 30303), 85 | ("188.63.78.132", 30303), 86 | ("128.12.255.172", 30303), 87 | ("90.35.135.242", 30303), 88 | ("82.232.60.209", 30303), 89 | ("87.215.30.74", 30303), 90 | ("129.194.81.234", 22318), 91 | ("178.19.221.38", 30303), 92 | ("94.174.162.250", 30303), 93 | ("193.138.219.234", 30303), 94 | ("188.122.16.76", 30303), 95 | ("71.237.182.164", 30303), 96 | ("207.12.89.180", 30303), 97 | ("207.12.89.180", 30300), 98 | ("84.72.161.78", 30303), 99 | ("173.238.50.70", 30303), 100 | ("90.213.167.21", 30303), 101 | ("120.148.4.242", 30303), 102 | ("67.237.187.247", 30303), 103 | ("77.101.50.246", 30303), 104 | ("88.168.242.87", 30300), 105 | ("40.141.47.2", 30303), 106 | ("109.201.154.150", 30303), 107 | ("5.228.251.149", 30303), 108 | ("79.205.244.3", 30303), 109 | ("77.129.6.180", 30303), 110 | ("208.52.154.136", 30300), 111 | ("199.254.238.167", 30303), 112 | ("80.185.170.70", 30303), 113 | ("188.220.9.241", 30303), 114 | ("129.194.81.234", 30303), 115 | ("76.100.20.104", 30300), 116 | ("162.210.197.234", 30303), 117 | ("89.246.69.218", 30303), 118 | ("178.19.221.38", 29341), 119 | ("217.91.252.61", 30303), 120 | ("118.241.70.83", 30303), 121 | ("190.17.13.160", 30303), 122 | ("68.7.46.39", 30303), 123 | ("99.36.164.218", 30301), 124 | ("37.157.38.10", 30303), 125 | ("24.176.161.133", 30303), 126 | ("82.113.99.187", 30303), 127 | ("194.151.205.61", 30303), 128 | ("54.235.157.173", 30303), 129 | ("95.91.210.151", 10101), 130 | ("108.59.8.182", 30303), 131 | ("217.247.70.175", 30303), 132 | ("173.238.52.23", 30303), 133 | ("82.217.72.169", 30304), 134 | ("176.114.249.240", 30303), 135 | ("178.19.221.38", 10101), 136 | ("87.149.174.176", 990), 137 | ("95.90.239.67", 30300), 138 | ("77.129.3.69", 30303), 139 | ("88.116.98.234", 30303), 140 | ("216.164.146.72", 22880), 141 | ("107.170.255.207", 30303), 142 | ("178.62.221.246", 30303), 143 | ("177.205.165.56", 30303), 144 | ("115.188.14.179", 112), 145 | ("145.129.59.101", 30303), 146 | ("64.134.53.142", 30303), 147 | ("68.142.28.137", 30303), 148 | ("162.243.131.173", 30303), 149 | ("81.181.146.231", 30303), 150 | ("23.22.211.45", 30303), 151 | ("24.134.75.192", 30303), 152 | ("188.63.251.204", 30303), 153 | ("93.159.121.155", 30303), 154 | ("109.20.132.214", 30303), 155 | ("204.50.102.246", 30303), 156 | ("50.245.145.217", 30303), 157 | ("86.143.179.69", 30303), 158 | ("77.50.138.143", 22228), 159 | ("23.22.211.45", 992), 160 | ("65.206.95.146", 30303), 161 | ("68.60.166.58", 30303), 162 | ("178.198.215.3", 30303), 163 | ("64.134.58.80", 30303), 164 | ("207.229.173.166", 30303), 165 | ("kobigurk.dyndns.org", 30303), 166 | ("37.142.103.9", 30303) 167 | ] 168 | 169 | -------------------------------------------------------------------------------- /src/Blockchain/VM/VMM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} 2 | 3 | module Blockchain.VM.VMM where 4 | 5 | import Control.Monad.Trans 6 | import Control.Monad.Trans.Either 7 | import Control.Monad.Trans.State 8 | import qualified Data.ByteString as B 9 | 10 | import Blockchain.Context 11 | import Blockchain.Data.Address 12 | import Blockchain.Data.AddressStateDB 13 | import Blockchain.Data.Log 14 | import qualified Blockchain.Database.MerklePatricia as MPDB 15 | import Blockchain.DB.ModifyStateDB 16 | import Blockchain.ExtWord 17 | import Blockchain.Data.RLP 18 | import Blockchain.DBM 19 | import Blockchain.Util 20 | import Blockchain.VM.Environment 21 | import Blockchain.VM.VMState 22 | import Blockchain.SHA 23 | import qualified Data.NibbleString as N 24 | 25 | 26 | type VMM = EitherT VMException (StateT VMState ContextM) 27 | 28 | 29 | class Word256Storable a where 30 | fromWord256::Word256->a 31 | toWord256::a->Word256 32 | 33 | instance Word256Storable Word256 where 34 | fromWord256 = id 35 | toWord256 = id 36 | 37 | instance Word256Storable Address where 38 | fromWord256 h = Address $ fromIntegral (h `mod` (2^(160::Integer))::Word256) 39 | toWord256 (Address h) = fromIntegral h 40 | 41 | instance Word256Storable SHA where 42 | fromWord256 h = SHA h 43 | toWord256 (SHA h) = h 44 | 45 | instance Word256Storable Int where 46 | fromWord256 = fromIntegral 47 | toWord256 = fromIntegral 48 | 49 | instance Word256Storable Integer where 50 | fromWord256 = fromIntegral 51 | toWord256 = fromIntegral 52 | 53 | pop::Word256Storable a=>VMM a 54 | pop = do 55 | state' <- lift get 56 | case state' of 57 | VMState{stack=val:rest} -> do 58 | lift $ put state'{stack=rest} 59 | return $ fromWord256 val 60 | _ -> left StackTooSmallException 61 | 62 | 63 | getStackItem::Word256Storable a=>Int->VMM a 64 | getStackItem i = do 65 | state' <- lift get 66 | if length (stack state') > fromIntegral i 67 | then return $ fromWord256 (stack state' !! i) 68 | else left StackTooSmallException 69 | 70 | push::Word256Storable a=>a->VMM () 71 | push val = do 72 | state' <- lift get 73 | lift $ put state'{stack = toWord256 val:stack state'} 74 | 75 | addDebugCallCreate::DebugCallCreate->VMM () 76 | addDebugCallCreate callCreate = do 77 | state' <- lift $ get 78 | case debugCallCreates state' of 79 | Just x -> lift $ put state'{debugCallCreates = Just (callCreate:x)} 80 | Nothing -> error "You are trying to add a call create during a non-debug run" 81 | 82 | addSuicideList::Address->VMM () 83 | addSuicideList address' = do 84 | state' <- lift get 85 | lift $ put state'{suicideList = address':suicideList state'} 86 | 87 | getEnvVar::(Environment->a)->VMM a 88 | getEnvVar f = do 89 | state' <- lift get 90 | return $ f $ environment state' 91 | 92 | addLog::Log->VMM () 93 | addLog newLog = do 94 | state' <- lift get 95 | lift $ put state'{logs=newLog:logs state'} 96 | 97 | setPC::Word256->VMM () 98 | setPC p = do 99 | state' <- lift get 100 | lift $ put state'{pc=p} 101 | 102 | incrementPC::Word256->VMM () 103 | incrementPC p = do 104 | state' <- lift get 105 | lift $ put state'{pc=pc state' + p} 106 | 107 | addToRefund::Integer->VMM () 108 | addToRefund val = do 109 | state' <- lift get 110 | lift $ put state'{refund=refund state' + val} 111 | 112 | getCallDepth::VMM Int 113 | getCallDepth = lift $ fmap callDepth $ get 114 | 115 | getGasRemaining::VMM Integer 116 | getGasRemaining = lift $ fmap vmGasRemaining $ get 117 | 118 | setDone::Bool->VMM () 119 | setDone done' = do 120 | state' <- lift get 121 | lift $ put state'{done=done'} 122 | 123 | setReturnVal::Maybe B.ByteString->VMM () 124 | setReturnVal returnVal' = do 125 | state' <- lift get 126 | lift $ put state'{returnVal=returnVal'} 127 | 128 | setGasRemaining::Integer->VMM () 129 | setGasRemaining gasRemaining' = do 130 | state' <- lift get 131 | lift $ put state'{vmGasRemaining=gasRemaining'} 132 | 133 | useGas::Integer->VMM () 134 | useGas gas = do 135 | state' <- lift get 136 | case vmGasRemaining state' - gas of 137 | x | x < 0 -> do 138 | lift $ put state'{vmGasRemaining=0} 139 | left OutOfGasException 140 | x -> lift $ put state'{vmGasRemaining=x} 141 | 142 | addGas::Integer->VMM () 143 | addGas gas = do 144 | state' <- lift get 145 | case vmGasRemaining state' + gas of 146 | x | x < 0 -> left OutOfGasException 147 | x -> lift $ put state'{vmGasRemaining=x} 148 | 149 | pay'::String->Address->Address->Integer->VMM () 150 | pay' reason from to val = do 151 | success <- lift $ lift $ pay reason from to val 152 | if success 153 | then return () 154 | else left InsufficientFunds 155 | 156 | addToBalance'::Address->Integer->VMM () 157 | addToBalance' address' val = do 158 | success <- lift $ lift $ addToBalance address' val 159 | if success 160 | then return () 161 | else left InsufficientFunds 162 | 163 | getStorageKeyVal::Word256->VMM Word256 164 | getStorageKeyVal key = do 165 | owner <- getEnvVar envOwner 166 | lift $ lift $ getStorageKeyVal' owner key 167 | 168 | getAllStorageKeyVals::VMM [(MPDB.Key, Word256)] 169 | getAllStorageKeyVals = do 170 | owner <- getEnvVar envOwner 171 | lift $ lift $ getAllStorageKeyVals' owner 172 | 173 | 174 | putStorageKeyVal::Word256->Word256->VMM () 175 | putStorageKeyVal key val = do 176 | owner <- getEnvVar envOwner 177 | lift $ lift $ putStorageKeyVal' owner key val 178 | 179 | deleteStorageKey::Word256->VMM () 180 | deleteStorageKey key = do 181 | owner <- getEnvVar envOwner 182 | lift $ lift $ deleteStorageKey' owner key 183 | 184 | -------------------------------------------------------------------------------- /fastNonceFinder/sha3.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2012 Vincent Hanquez 3 | * 4 | * Redistribution and use in source and binary forms, with or without 5 | * modification, are permitted provided that the following conditions 6 | * are met: 7 | * 1. Redistributions of source code must retain the above copyright 8 | * notice, this list of conditions and the following disclaimer. 9 | * 2. Redistributions in binary form must reproduce the above copyright 10 | * notice, this list of conditions and the following disclaimer in the 11 | * documentation and/or other materials provided with the distribution. 12 | * 13 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 14 | * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 15 | * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 16 | * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 17 | * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 18 | * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 19 | * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 20 | * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 22 | * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | */ 24 | 25 | #include 26 | #include 27 | #include "bitfn.h" 28 | #include "sha3.h" 29 | 30 | #define KECCAK_NB_ROUNDS 24 31 | 32 | /* rounds constants */ 33 | static const uint64_t keccak_rndc[24] = 34 | { 35 | 0x0000000000000001ULL, 0x0000000000008082ULL, 0x800000000000808aULL, 36 | 0x8000000080008000ULL, 0x000000000000808bULL, 0x0000000080000001ULL, 37 | 0x8000000080008081ULL, 0x8000000000008009ULL, 0x000000000000008aULL, 38 | 0x0000000000000088ULL, 0x0000000080008009ULL, 0x000000008000000aULL, 39 | 0x000000008000808bULL, 0x800000000000008bULL, 0x8000000000008089ULL, 40 | 0x8000000000008003ULL, 0x8000000000008002ULL, 0x8000000000000080ULL, 41 | 0x000000000000800aULL, 0x800000008000000aULL, 0x8000000080008081ULL, 42 | 0x8000000000008080ULL, 0x0000000080000001ULL, 0x8000000080008008ULL, 43 | }; 44 | 45 | /* triangular numbers constants */ 46 | static const int keccak_rotc[24] = 47 | { 1,3,6,10,15,21,28,36,45,55,2,14,27,41,56,8,25,43,62,18,39,61,20,44 }; 48 | 49 | static const int keccak_piln[24] = 50 | { 10,7,11,17,18,3,5,16,8,21,24,4,15,23,19,13,12,2,20,14,22,9,6,1 }; 51 | 52 | static inline void sha3_do_chunk(uint64_t state[25], uint64_t buf[], int bufsz) 53 | { 54 | int i, j, r; 55 | uint64_t tmp, bc[5]; 56 | 57 | /* merge buf with state */ 58 | for (i = 0; i < bufsz; i++) 59 | state[i] ^= le64_to_cpu(buf[i]); 60 | 61 | /* run keccak rounds */ 62 | for (r = 0; r < KECCAK_NB_ROUNDS; r++) { 63 | /* compute the parity of each columns */ 64 | for (i = 0; i < 5; i++) 65 | bc[i] = state[i] ^ state[i+5] ^ state[i+10] ^ state[i+15] ^ state[i+20]; 66 | 67 | for (i = 0; i < 5; i++) { 68 | tmp = bc[(i + 4) % 5] ^ rol64(bc[(i + 1) % 5], 1); 69 | for (j = 0; j < 25; j += 5) 70 | state[j + i] ^= tmp; 71 | } 72 | 73 | /* rho pi */ 74 | tmp = state[1]; 75 | for (i = 0; i < 24; i++) { 76 | j = keccak_piln[i]; 77 | bc[0] = state[j]; 78 | state[j] = rol64(tmp, keccak_rotc[i]); 79 | tmp = bc[0]; 80 | } 81 | 82 | /* bitwise combine along rows using a = a xor (not b and c) */ 83 | for (j = 0; j < 25; j += 5) { 84 | for (i = 0; i < 5; i++) 85 | bc[i] = state[j + i]; 86 | #define andn(b,c) (~(b) & (c)) 87 | state[j + 0] ^= andn(bc[1], bc[2]); 88 | state[j + 1] ^= andn(bc[2], bc[3]); 89 | state[j + 2] ^= andn(bc[3], bc[4]); 90 | state[j + 3] ^= andn(bc[4], bc[0]); 91 | state[j + 4] ^= andn(bc[0], bc[1]); 92 | #undef andn 93 | } 94 | 95 | /* xor the round constant */ 96 | state[0] ^= keccak_rndc[r]; 97 | } 98 | } 99 | 100 | void sha3_init(struct sha3_ctx *ctx, uint32_t hashlen) 101 | { 102 | memset(ctx, 0, sizeof(*ctx)); 103 | ctx->hashlen = hashlen / 8; 104 | ctx->bufsz = 200 - 2 * ctx->hashlen; 105 | } 106 | 107 | void sha3_update(struct sha3_ctx *ctx, uint8_t *data, uint32_t len) 108 | { 109 | uint32_t to_fill; 110 | 111 | to_fill = ctx->bufsz - ctx->bufindex; 112 | 113 | if (ctx->bufindex == ctx->bufsz) { 114 | sha3_do_chunk(ctx->state, (uint64_t *) ctx->buf, ctx->bufsz / 8); 115 | ctx->bufindex = 0; 116 | } 117 | 118 | /* process partial buffer if there's enough data to make a block */ 119 | if (ctx->bufindex && len >= to_fill) { 120 | memcpy(ctx->buf + ctx->bufindex, data, to_fill); 121 | sha3_do_chunk(ctx->state, (uint64_t *) ctx->buf, ctx->bufsz / 8); 122 | len -= to_fill; 123 | data += to_fill; 124 | ctx->bufindex = 0; 125 | } 126 | 127 | /* process as much ctx->bufsz-block */ 128 | for (; len >= ctx->bufsz; len -= ctx->bufsz, data += ctx->bufsz) 129 | sha3_do_chunk(ctx->state, (uint64_t *) data, ctx->bufsz / 8); 130 | 131 | /* append data into buf */ 132 | if (len) { 133 | memcpy(ctx->buf + ctx->bufindex, data, len); 134 | ctx->bufindex += len; 135 | } 136 | } 137 | 138 | void sha3_finalize(struct sha3_ctx *ctx, uint8_t *out) 139 | { 140 | uint64_t w[25]; 141 | 142 | /* process full buffer if needed */ 143 | if (ctx->bufindex == ctx->bufsz) { 144 | sha3_do_chunk(ctx->state, (uint64_t *) ctx->buf, ctx->bufsz / 8); 145 | ctx->bufindex = 0; 146 | } 147 | 148 | /* add the 10*1 padding */ 149 | ctx->buf[ctx->bufindex++] = 1; 150 | memset(ctx->buf + ctx->bufindex, 0, ctx->bufsz - ctx->bufindex); 151 | ctx->buf[ctx->bufsz - 1] |= 0x80; 152 | 153 | /* process */ 154 | sha3_do_chunk(ctx->state, (uint64_t *) ctx->buf, ctx->bufsz / 8); 155 | 156 | /* output */ 157 | cpu_to_le64_array(w, ctx->state, 25); 158 | memcpy(out, w, ctx->hashlen); 159 | } 160 | -------------------------------------------------------------------------------- /src/Blockchain/VM/Memory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | module Blockchain.VM.Memory ( 3 | Memory(..), 4 | getSizeInBytes, 5 | getSizeInWords, 6 | getShow, 7 | getMemAsByteString, 8 | mLoad, 9 | mLoad8, 10 | mLoadByteString, 11 | unsafeSliceByteString, 12 | mStore, 13 | mStore8, 14 | mStoreByteString 15 | ) where 16 | 17 | import Control.Monad 18 | import Control.Monad.Trans 19 | import Control.Monad.Trans.Either 20 | import Control.Monad.Trans.State hiding (state) 21 | import qualified Data.Vector.Storable.Mutable as V 22 | import qualified Data.ByteString as B 23 | import qualified Data.ByteString.Base16 as B16 24 | import Data.Functor 25 | import Data.IORef 26 | import Data.Word 27 | import Foreign 28 | --import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 29 | 30 | import qualified Blockchain.Colors as CL 31 | import Blockchain.ExtWord 32 | import Blockchain.Util 33 | import Blockchain.VM.OpcodePrices 34 | import Blockchain.VM.VMState 35 | import Blockchain.VM.VMM 36 | 37 | safeRead::V.IOVector Word8->Word256->IO Word8 38 | safeRead _ x | x > 0x7fffffffffffffff = return 0 --There is no way that memory will be filled up this high, it would cost too much gas. I think it is safe to assume it is zero. 39 | --safeRead _ x | x > 0x7fffffffffffffff = error "error in safeRead, value too large" 40 | safeRead mem x = do 41 | let len = V.length mem 42 | if x < fromIntegral len 43 | then V.read mem (fromIntegral x) 44 | else return 0 45 | 46 | --Word256 is too big to use for [first..first+size-1], so use safeRange instead 47 | safeRange::Word256->Word256->[Word256] 48 | safeRange _ 0 = [] 49 | safeRange first size = first:safeRange (first+1) (size-1) 50 | 51 | getSizeInWords::VMM Word256 52 | getSizeInWords = do 53 | state <- lift get 54 | let (Memory _ size) = memory state 55 | liftIO $ (ceiling . (/ (32::Double)) . fromIntegral) <$> readIORef size 56 | 57 | getSizeInBytes::VMM Word256 58 | getSizeInBytes = do 59 | state <- lift get 60 | let (Memory _ size) = memory state 61 | liftIO $ fromIntegral <$> readIORef size 62 | 63 | --In this function I use the words "size" and "length" to mean 2 different things.... 64 | --"size" is the highest memory location used (as described in the yellowpaper). 65 | --"length" is the IOVector length, which will often be larger than the size. 66 | --Basically, to avoid resizing the vector constantly (which could be expensive), 67 | --I keep something larger around until it fills up, then reallocate (something even 68 | --larger). 69 | setNewMaxSize::Integer->VMM () 70 | setNewMaxSize newSize' = do 71 | --TODO- I should just store the number of words.... memory size can only be a multiple of words. 72 | --For now I will just use this hack to allocate to the nearest higher number of words. 73 | let newSize = 32 * ceiling (fromIntegral newSize'/(32::Double))::Integer 74 | state <- lift get 75 | 76 | oldSize <- liftIO $ readIORef (mSize $ memory state) 77 | 78 | 79 | let gasCharge = 80 | if newSize > fromIntegral oldSize 81 | then 82 | let newWordSize = fromInteger $ (ceiling $ fromIntegral newSize/(32::Double)) 83 | oldWordSize = (ceiling $ fromIntegral oldSize/(32::Double)) 84 | sizeCost c = gMEMWORD * c + (c*c `quot` gQUADCOEFFDIV) 85 | in sizeCost newWordSize - sizeCost oldWordSize 86 | else 0 87 | 88 | let oldLength = fromIntegral $ V.length (mVector $ memory state) 89 | 90 | if vmGasRemaining state < gasCharge 91 | then do 92 | setGasRemaining 0 93 | left OutOfGasException 94 | else do 95 | when (newSize > fromIntegral oldSize) $ do 96 | liftIO $ writeIORef (mSize $ memory state) (fromInteger newSize) 97 | if newSize > oldLength 98 | then do 99 | state' <- lift get 100 | when (newSize > 100000000) $ liftIO $ putStrLn $ CL.red ("Warning, memory needs to grow to a huge value: " ++ show (fromIntegral newSize/1000000) ++ "MB") 101 | arr' <- liftIO $ V.grow (mVector $ memory state') $ fromIntegral $ (newSize+1000000) 102 | when (newSize > 100000000) $ liftIO $ putStrLn $ CL.red $ "clearing out memory" 103 | --liftIO $ forM_ [oldLength..(newSize+1000000)-1] $ \p -> V.write arr' (fromIntegral p) 0 104 | liftIO $ V.set (V.unsafeSlice (fromIntegral oldLength) (fromIntegral newSize+1000000) arr') 0 105 | when (newSize > 100000000) $ liftIO $ putStrLn $ CL.red $ "Finished growing memory" 106 | lift $ put $ state'{memory=(memory state'){mVector = arr'}} 107 | else return () 108 | 109 | useGas gasCharge 110 | 111 | getShow::Memory->IO String 112 | getShow (Memory arr sizeRef) = do 113 | msize <- readIORef sizeRef 114 | --fmap (show . B16.encode . B.pack) $ sequence $ V.read arr <$> fromIntegral <$> [0..fromIntegral msize-1] 115 | fmap (show . B16.encode . B.pack) $ sequence $ safeRead arr <$> [0..fromIntegral msize-1] 116 | 117 | getMemAsByteString::Memory->IO B.ByteString 118 | getMemAsByteString (Memory arr sizeRef) = do 119 | msize <- readIORef sizeRef 120 | liftIO $ fmap B.pack $ sequence $ safeRead arr <$> [0..fromIntegral msize-1] 121 | 122 | mLoad::Word256->VMM [Word8] 123 | mLoad p = do 124 | setNewMaxSize (fromIntegral p+32) 125 | state <- lift get 126 | liftIO $ sequence $ safeRead (mVector $ memory state) <$> safeRange p 32 127 | 128 | mLoad8::Word256->VMM Word8 129 | mLoad8 p = do 130 | --setNewMaxSize m p 131 | state <- lift get 132 | liftIO $ safeRead (mVector $ memory state) (fromIntegral p) 133 | 134 | mLoadByteString::Word256->Word256->VMM B.ByteString 135 | mLoadByteString _ 0 = return B.empty --no need to charge gas for mem change if nothing returned 136 | mLoadByteString p size = do 137 | setNewMaxSize (fromIntegral p+fromIntegral size) 138 | state <- lift get 139 | val <- liftIO $ fmap B.pack $ sequence $ safeRead (mVector $ memory state) <$> fromIntegral <$> safeRange p size 140 | return val 141 | 142 | unsafeSliceByteString::Word256->Word256->VMM B.ByteString 143 | unsafeSliceByteString p size = do 144 | setNewMaxSize (fromIntegral p+fromIntegral size) 145 | state <- lift get 146 | let (fptr, len) = V.unsafeToForeignPtr0 (V.slice (fromIntegral p) (fromIntegral size) $ mVector $ memory state) 147 | liftIO $ withForeignPtr fptr $ \ptr -> 148 | B.packCStringLen (castPtr ptr, len * sizeOf (undefined :: Word8)) 149 | 150 | 151 | mStore::Word256->Word256->VMM () 152 | mStore p val = do 153 | setNewMaxSize (fromIntegral p+32) 154 | state <- lift get 155 | liftIO $ sequence_ $ uncurry (V.write $ mVector $ memory state) <$> zip [fromIntegral p..] (word256ToBytes val) 156 | 157 | mStore8::Word256->Word8->VMM () 158 | mStore8 p val = do 159 | setNewMaxSize (fromIntegral p+1) 160 | state <- lift get 161 | liftIO $ V.write (mVector $ memory state) (fromIntegral p) val 162 | 163 | mStoreByteString::Word256->B.ByteString->VMM () 164 | mStoreByteString p theData = do 165 | setNewMaxSize (fromIntegral p + fromIntegral (B.length theData)) 166 | state <- lift get 167 | liftIO $ sequence_ $ uncurry (V.write $ mVector $ memory state) <$> zip (fromIntegral <$> safeRange p (fromIntegral $ B.length theData)) (B.unpack theData) 168 | 169 | -------------------------------------------------------------------------------- /fastNonceFinder/bitfn.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2006-2009 Vincent Hanquez 3 | * 4 | * Redistribution and use in source and binary forms, with or without 5 | * modification, are permitted provided that the following conditions 6 | * are met: 7 | * 1. Redistributions of source code must retain the above copyright 8 | * notice, this list of conditions and the following disclaimer. 9 | * 2. Redistributions in binary form must reproduce the above copyright 10 | * notice, this list of conditions and the following disclaimer in the 11 | * documentation and/or other materials provided with the distribution. 12 | * 13 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 14 | * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 15 | * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 16 | * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 17 | * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 18 | * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 19 | * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 20 | * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 22 | * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | */ 24 | 25 | #ifndef BITFN_H 26 | #define BITFN_H 27 | #include 28 | 29 | #ifndef NO_INLINE_ASM 30 | /**********************************************************/ 31 | # if (defined(__i386__)) 32 | # define ARCH_HAS_SWAP32 33 | static inline uint32_t bitfn_swap32(uint32_t a) 34 | { 35 | asm ("bswap %0" : "=r" (a) : "0" (a)); 36 | return a; 37 | } 38 | /**********************************************************/ 39 | # elif (defined(__arm__)) 40 | # define ARCH_HAS_SWAP32 41 | static inline uint32_t bitfn_swap32(uint32_t a) 42 | { 43 | uint32_t tmp = a; 44 | asm volatile ("eor %1, %0, %0, ror #16\n" 45 | "bic %1, %1, #0xff0000\n" 46 | "mov %0, %0, ror #8\n" 47 | "eor %0, %0, %1, lsr #8\n" 48 | : "=r" (a), "=r" (tmp) : "0" (a), "1" (tmp)); 49 | return a; 50 | } 51 | /**********************************************************/ 52 | # elif defined(__x86_64__) 53 | # define ARCH_HAS_SWAP32 54 | # define ARCH_HAS_SWAP64 55 | static inline uint32_t bitfn_swap32(uint32_t a) 56 | { 57 | asm ("bswap %0" : "=r" (a) : "0" (a)); 58 | return a; 59 | } 60 | 61 | static inline uint64_t bitfn_swap64(uint64_t a) 62 | { 63 | asm ("bswap %0" : "=r" (a) : "0" (a)); 64 | return a; 65 | } 66 | 67 | # endif 68 | #endif /* NO_INLINE_ASM */ 69 | /**********************************************************/ 70 | 71 | #ifndef ARCH_HAS_ROL32 72 | static inline uint32_t rol32(uint32_t word, uint32_t shift) 73 | { 74 | return (word << shift) | (word >> (32 - shift)); 75 | } 76 | #endif 77 | 78 | #ifndef ARCH_HAS_ROR32 79 | static inline uint32_t ror32(uint32_t word, uint32_t shift) 80 | { 81 | return (word >> shift) | (word << (32 - shift)); 82 | } 83 | #endif 84 | 85 | #ifndef ARCH_HAS_ROL64 86 | static inline uint64_t rol64(uint64_t word, uint32_t shift) 87 | { 88 | return (word << shift) | (word >> (64 - shift)); 89 | } 90 | #endif 91 | 92 | #ifndef ARCH_HAS_ROR64 93 | static inline uint64_t ror64(uint64_t word, uint32_t shift) 94 | { 95 | return (word >> shift) | (word << (64 - shift)); 96 | } 97 | #endif 98 | 99 | #ifndef ARCH_HAS_SWAP32 100 | static inline uint32_t bitfn_swap32(uint32_t a) 101 | { 102 | return (a << 24) | ((a & 0xff00) << 8) | ((a >> 8) & 0xff00) | (a >> 24); 103 | } 104 | #endif 105 | 106 | #ifndef ARCH_HAS_ARRAY_SWAP32 107 | static inline void array_swap32(uint32_t *d, uint32_t *s, uint32_t nb) 108 | { 109 | while (nb--) 110 | *d++ = bitfn_swap32(*s++); 111 | } 112 | #endif 113 | 114 | #ifndef ARCH_HAS_SWAP64 115 | static inline uint64_t bitfn_swap64(uint64_t a) 116 | { 117 | return ((uint64_t) bitfn_swap32((uint32_t) (a >> 32))) | 118 | (((uint64_t) bitfn_swap32((uint32_t) a)) << 32); 119 | } 120 | #endif 121 | 122 | #ifndef ARCH_HAS_ARRAY_SWAP64 123 | static inline void array_swap64(uint64_t *d, uint64_t *s, uint32_t nb) 124 | { 125 | while (nb--) 126 | *d++ = bitfn_swap64(*s++); 127 | } 128 | #endif 129 | 130 | #ifndef ARCH_HAS_MEMORY_ZERO 131 | static inline void memory_zero(void *ptr, uint32_t len) 132 | { 133 | uint32_t *ptr32 = ptr; 134 | uint8_t *ptr8; 135 | int i; 136 | 137 | for (i = 0; i < len / 4; i++) 138 | *ptr32++ = 0; 139 | if (len % 4) { 140 | ptr8 = (uint8_t *) ptr32; 141 | for (i = len % 4; i >= 0; i--) 142 | ptr8[i] = 0; 143 | } 144 | } 145 | #endif 146 | 147 | #ifndef ARCH_HAS_ARRAY_COPY32 148 | static inline void array_copy32(uint32_t *d, uint32_t *s, uint32_t nb) 149 | { 150 | while (nb--) *d++ = *s++; 151 | } 152 | #endif 153 | 154 | #ifndef ARCH_HAS_ARRAY_COPY64 155 | static inline void array_copy64(uint64_t *d, uint64_t *s, uint32_t nb) 156 | { 157 | while (nb--) *d++ = *s++; 158 | } 159 | #endif 160 | 161 | #ifdef __MINGW32__ 162 | # define LITTLE_ENDIAN 1234 163 | # define BYTE_ORDER LITTLE_ENDIAN 164 | #elif defined(__FreeBSD__) || defined(__DragonFly__) || defined(__NetBSD__) 165 | # include 166 | #elif defined(__OpenBSD__) || defined(__SVR4) 167 | # include 168 | #elif defined(__APPLE__) 169 | # include 170 | #elif defined( BSD ) && ( BSD >= 199103 ) 171 | # include 172 | #elif defined( __QNXNTO__ ) && defined( __LITTLEENDIAN__ ) 173 | # define LITTLE_ENDIAN 1234 174 | # define BYTE_ORDER LITTLE_ENDIAN 175 | #elif defined( __QNXNTO__ ) && defined( __BIGENDIAN__ ) 176 | # define BIG_ENDIAN 1234 177 | # define BYTE_ORDER BIG_ENDIAN 178 | #else 179 | # include 180 | #endif 181 | /* big endian to cpu */ 182 | #if LITTLE_ENDIAN == BYTE_ORDER 183 | 184 | # define be32_to_cpu(a) bitfn_swap32(a) 185 | # define cpu_to_be32(a) bitfn_swap32(a) 186 | # define le32_to_cpu(a) (a) 187 | # define cpu_to_le32(a) (a) 188 | # define be64_to_cpu(a) bitfn_swap64(a) 189 | # define cpu_to_be64(a) bitfn_swap64(a) 190 | # define le64_to_cpu(a) (a) 191 | # define cpu_to_le64(a) (a) 192 | 193 | # define cpu_to_le32_array(d, s, l) array_copy32(d, s, l) 194 | # define le32_to_cpu_array(d, s, l) array_copy32(d, s, l) 195 | # define cpu_to_be32_array(d, s, l) array_swap32(d, s, l) 196 | # define be32_to_cpu_array(d, s, l) array_swap32(d, s, l) 197 | 198 | # define cpu_to_le64_array(d, s, l) array_copy64(d, s, l) 199 | # define le64_to_cpu_array(d, s, l) array_copy64(d, s, l) 200 | # define cpu_to_be64_array(d, s, l) array_swap64(d, s, l) 201 | # define be64_to_cpu_array(d, s, l) array_swap64(d, s, l) 202 | 203 | # define ror32_be(a, s) rol32(a, s) 204 | # define rol32_be(a, s) ror32(a, s) 205 | 206 | # define ARCH_IS_LITTLE_ENDIAN 207 | 208 | #elif BIG_ENDIAN == BYTE_ORDER 209 | 210 | # define be32_to_cpu(a) (a) 211 | # define cpu_to_be32(a) (a) 212 | # define be64_to_cpu(a) (a) 213 | # define cpu_to_be64(a) (a) 214 | # define le64_to_cpu(a) bitfn_swap64(a) 215 | # define cpu_to_le64(a) bitfn_swap64(a) 216 | # define le32_to_cpu(a) bitfn_swap32(a) 217 | # define cpu_to_le32(a) bitfn_swap32(a) 218 | 219 | # define cpu_to_le32_array(d, s, l) array_swap32(d, s, l) 220 | # define le32_to_cpu_array(d, s, l) array_swap32(d, s, l) 221 | # define cpu_to_be32_array(d, s, l) array_copy32(d, s, l) 222 | # define be32_to_cpu_array(d, s, l) array_copy32(d, s, l) 223 | 224 | # define cpu_to_le64_array(d, s, l) array_swap64(d, s, l) 225 | # define le64_to_cpu_array(d, s, l) array_swap64(d, s, l) 226 | # define cpu_to_be64_array(d, s, l) array_copy64(d, s, l) 227 | # define be64_to_cpu_array(d, s, l) array_copy64(d, s, l) 228 | 229 | # define ror32_be(a, s) ror32(a, s) 230 | # define rol32_be(a, s) rol32(a, s) 231 | 232 | # define ARCH_IS_BIG_ENDIAN 233 | 234 | #else 235 | # error "endian not supported" 236 | #endif 237 | 238 | #endif /* !BITFN_H */ 239 | -------------------------------------------------------------------------------- /src/Blockchain/Data/GenesisBlock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TupleSections #-} 2 | 3 | module Blockchain.Data.GenesisBlock ( 4 | initializeGenesisBlock, 5 | initializeStateDB 6 | ) where 7 | 8 | import Control.Monad 9 | import Control.Monad.IO.Class 10 | import Control.Monad.Trans 11 | import Control.Monad.Trans.Resource 12 | import Control.Monad.Trans.State 13 | import Data.Bits 14 | import qualified Data.ByteString as B 15 | import qualified Data.ByteString.Base16 as B16 16 | import Data.Functor 17 | import Data.Time.Clock.POSIX 18 | 19 | import Blockchain.Database.MerklePatricia 20 | 21 | import Blockchain.Constants 22 | import Blockchain.Context 23 | import Blockchain.Data.Address 24 | import Blockchain.Data.AddressStateDB 25 | import Blockchain.Data.BlockDB 26 | import Blockchain.Data.DataDefs 27 | import Blockchain.Data.DiffDB 28 | import Blockchain.DB.ModifyStateDB 29 | import Blockchain.DBM 30 | import Blockchain.ExtWord 31 | import Blockchain.SHA 32 | 33 | 34 | import Blockchain.Format 35 | import Blockchain.Data.RLP 36 | 37 | --import Debug.Trace 38 | 39 | --startingRoot::B.ByteString 40 | --(startingRoot, "") = B16.decode "c5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470" 41 | --"bc36789e7a1e281436464229828f817d6612f7b477d66591ff96a9e064bcc98a" 42 | 43 | initializeBlankStateDB::ContextM () 44 | initializeBlankStateDB = do 45 | dbs <- lift get 46 | liftIO $ runResourceT $ 47 | initializeBlank (stateDB dbs) 48 | lift $ put dbs{stateDB=(stateDB dbs){stateRoot=emptyTriePtr}} 49 | 50 | initializeStateDB::ContextM () 51 | initializeStateDB = do 52 | initializeBlankStateDB 53 | 54 | let canonicalAddressInfo = 55 | [ 56 | (0x0000000000000000000000000000000000000001, 1 * wei), 57 | (0x0000000000000000000000000000000000000002, 1 * wei), 58 | (0x0000000000000000000000000000000000000003, 1 * wei), 59 | (0x0000000000000000000000000000000000000004, 1 * wei), 60 | (0xdbdbdb2cbd23b783741e8d7fcf51e459b497e4a6, 1606938044258990275541962092341162602522202993782792835301376 * wei), 61 | (0xe6716f9544a56c530d868e4bfbacb172315bdead, 1606938044258990275541962092341162602522202993782792835301376 * wei), 62 | (0xb9c015918bdaba24b4ff057a92a3873d6eb201be, 1606938044258990275541962092341162602522202993782792835301376 * wei), 63 | (0x1a26338f0d905e295fccb71fa9ea849ffa12aaf4, 1606938044258990275541962092341162602522202993782792835301376 * wei), 64 | (0x2ef47100e0787b915105fd5e3f4ff6752079d5cb, 1606938044258990275541962092341162602522202993782792835301376 * wei), 65 | (0xcd2a3d9f938e13cd947ec05abc7fe734df8dd826, 1606938044258990275541962092341162602522202993782792835301376 * wei), 66 | (0x6c386a4b26f73c802f34673f7248bb118f97424a, 1606938044258990275541962092341162602522202993782792835301376 * wei), 67 | (0xe4157b34ea9615cfbde6b4fda419828124b70c78, 1606938044258990275541962092341162602522202993782792835301376 * wei) 68 | ] 69 | 70 | let alternateAddresses = 71 | [ 72 | 0xe1fd0d4a52b75a694de8b55528ad48e2e2cf7859, 73 | 74 | 0xaf8b2d3fe28201476fc0a3961f8f9690693f3ef4, 75 | 0x51a7b750eef433d30b607588f148b1916e809a57, 76 | 0x782eb06293e83013a27fe9a1565024f8de69c4e6, 77 | 0x45186086fed161da87c1adfe2cc0959527bdeb88, 78 | 0xb2e30da3a268fecf2da0bf3ce2ac585fc061abbe, 79 | 0x8eb0d47301ca98f19a9f6084926ca05e8db8d464, 80 | 0x5508f4a16df16b7a1c7e91bdae9e7e39fbbe1ff4, 81 | 0x259eb98117964225ebfc6e36240a5c4691a3c713, 82 | 0xe5517ed95c86dd485882b05fb2810a4ecbd8a408, 83 | 0xeeca09c9ce60d0bc611321bed0946e5fb7a16d37, 84 | 0x189ed0357fe1e21a77f910e972ede149370c38e4, 85 | 0x68a03e2e5c82a1abb1cbe00a61a95429f33c4b6b, 86 | 0xc3f4ad9d47bfe5cb8fb5d9e0ea551920dabf6864, 87 | 0x7c46dafbab2ed794ac06a19ee2d5e13ac4a8aef6, 88 | 0x37acd0bde7ed52ebe5ed248c178925649e71c4cf, 89 | 0xe9268b4e8347d490b882ea5c7353fa77115401c2, 90 | 0xe194c5fbc5779b4543fa6c4160176563acd640a7, 91 | 0xc8ee43b12a93a6d3a70bc65cdf8d8025cfdb541c, 92 | 0x2e8496cccee0512f9998c705c033be824ca4f4dd, 93 | 0xb2eafe67d2a39ecf612fc4cdd603001049fc72e0, 94 | 0x6ff6c2d937cf5a31a0d9a59364465ad91d454829, 95 | 0xa320f8711110fb9ee0a3b0205332045fdcd8e003, 96 | 0xe53ee7e0ad171aea4266d45365c32c6e8a45c938, 97 | 0x91da47c2864b1a5a187c7d0d8325b8bd9e65b628, 98 | 0x03d1b8a84cf8bf47fd095689b177312db60c12e9, 99 | 0x964e04041948bef28afadf5b60cf37303af371a0, 100 | 0x7afcf309ea63569bcb25818db72c85965eca6975, 101 | 0x165957d17265ed3f84ae3f0c70f709cbf24ec6cd, 102 | 0x189d231bc2a10f140b596914f960d5882d84e874, 103 | 0x75b082195b59660c20965f71d8ceb6dbb0d44da2, 104 | 0x2f52c22cfd08987c079772d531dece6c792a49b, 105 | 0xe946066f6f02051a3a90e82149b0541b5da19d1, 106 | 0x3049e55d9d9ad702dae2776b5d739cee66b766a6, 107 | 0x8a0efc1e4a419274a84535b419183f0833bf9a00, 108 | 0xd2752fb239da7494e2aa0b28f3677c59db0db23f, 109 | 0xec9ddd74505d37daf3b6a60a2d14c2e6b631d3ce, 110 | 0x93e61dfc56715bd0e924dfecbe17dbb54e5959c5, 111 | 0xb5a780a4baca2e220e5a525220ee0969b5278475, 112 | 0x99628e3c65acd923446b7948895a4d464c7d0d2c, 113 | 0xb024b78b9ad5a65eccf7f852f430796396c8fbd8, 114 | 0x5cef2aa68a9ccdb23b1326e9b5a29dbc0f1e79cf, 115 | 0x0d6a1f62bcd926b623b72ab4c6a692496736d395, 116 | 0x2b5f3d3cfc176bd77e42e99a0f2132605524d629, 117 | 0xf40cf138e9dd48837e07b7a8e65c1bf20a9ba0e9, 118 | 0x825f7814d778ee708d7be40d5f5c0f44317965f2, 119 | 0x8b941081307156ad6e428c2e74a2bbf70054004d, 120 | 0x0065e00f66ec04bd33019aa721a74ed7b02db9c9, 121 | 0x24da7b589fa048ce38aa40b661bfb1647b925fde, 122 | 0xa7ddd7558321d6ce4bbbf96b6905d98a9968bfdd, 123 | 0x5827a72671940a93d99ec86f47db244d0e0fa442 124 | ] 125 | 126 | let alternateAddressInfo = map (, 1 `shiftL` 250) alternateAddresses 127 | 128 | cxt <- get 129 | 130 | let addressInfo = if useAlternateGenesisBlock cxt then alternateAddressInfo else canonicalAddressInfo 131 | 132 | forM_ addressInfo $ \(address, balance) -> 133 | lift $ putAddressState (Address address) blankAddressState{addressStateBalance=balance} 134 | 135 | initializeGenesisBlock::ContextM Block 136 | initializeGenesisBlock = do 137 | initializeStateDB 138 | dbs <- lift get 139 | let genesisBlock = Block { 140 | blockBlockData = 141 | BlockData { 142 | blockDataParentHash = SHA 0, 143 | blockDataUnclesHash = hash (B.pack [0xc0]), 144 | blockDataCoinbase = Address 0, 145 | --blockDataStateRoot = SHAPtr $ fst $ B16.decode "9178d0f23c965d81f0834a4c72c6253ce6830f4022b1359aaebfc1ecba442d4e", -- stateRoot $ stateDB dbs, 146 | blockDataStateRoot = stateRoot $ stateDB dbs, 147 | blockDataTransactionsRoot = emptyTriePtr, 148 | blockDataReceiptsRoot = emptyTriePtr, 149 | blockDataLogBloom = B.replicate 256 0, 150 | blockDataDifficulty = 0x020000, --1 << 17 151 | blockDataNumber = 0, 152 | blockDataGasLimit = 3141592, 153 | blockDataGasUsed = 0, 154 | blockDataTimestamp = posixSecondsToUTCTime 0, 155 | blockDataExtraData = 0, 156 | blockDataMixHash = SHA 0, 157 | blockDataNonce = 42 -- hash $ B.pack [42] 158 | }, 159 | blockReceiptTransactions=[], 160 | blockBlockUncles=[] 161 | } 162 | genBlkId <- lift $ putBlock genesisBlock 163 | genAddrStates <- lift $ getAllAddressStates 164 | let diffFromPair (addr, addrS) = CreateAddr addr addrS 165 | lift $ commitSqlDiffs genBlkId 0 $ map diffFromPair genAddrStates 166 | 167 | return genesisBlock 168 | 169 | 170 | 171 | 172 | -------------------------------------------------------------------------------- /src/Blockchain/VM/Opcodes.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.VM.Opcodes where 3 | 4 | import Prelude hiding (LT, GT, EQ) 5 | 6 | import Data.Binary 7 | import qualified Data.ByteString as B 8 | import Data.Functor 9 | import qualified Data.Map as M 10 | import Data.Maybe 11 | import Network.Haskoin.Internals 12 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 13 | 14 | import Blockchain.Util 15 | 16 | --import Debug.Trace 17 | 18 | data Operation = 19 | 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 | 20 | ADDRESS | BALANCE | ORIGIN | CALLER | CALLVALUE | CALLDATALOAD | CALLDATASIZE | CALLDATACOPY | CODESIZE | CODECOPY | GASPRICE | EXTCODESIZE | EXTCODECOPY | 21 | BLOCKHASH | COINBASE | TIMESTAMP | NUMBER | DIFFICULTY | GASLIMIT | POP | MLOAD | MSTORE | MSTORE8 | SLOAD | SSTORE | 22 | JUMP | JUMPI | PC | MSIZE | GAS | JUMPDEST | 23 | PUSH [Word8] | 24 | DUP1 | DUP2 | DUP3 | DUP4 | 25 | DUP5 | DUP6 | DUP7 | DUP8 | 26 | DUP9 | DUP10 | DUP11 | DUP12 | 27 | DUP13 | DUP14 | DUP15 | DUP16 | 28 | SWAP1 | SWAP2 | SWAP3 | SWAP4 | 29 | SWAP5 | SWAP6 | SWAP7 | SWAP8 | 30 | SWAP9 | SWAP10 | SWAP11 | SWAP12 | 31 | SWAP13 | SWAP14 | SWAP15 | SWAP16 | 32 | LOG0 | LOG1 | LOG2 | LOG3 | LOG4 | 33 | CREATE | CALL | RETURN | CALLCODE | SUICIDE | 34 | --Pseudo Opcodes 35 | LABEL String | PUSHLABEL String | 36 | PUSHDIFF String String | DATA B.ByteString | 37 | MalformedOpcode Word8 deriving (Show, Eq, Ord) 38 | 39 | instance Pretty Operation where 40 | pretty x@JUMPDEST = text $ "------" ++ show x 41 | pretty x@(PUSH vals) = text $ show x ++ " --" ++ show (bytes2Integer vals) 42 | pretty x = text $ show x 43 | 44 | data OPData = OPData Word8 Operation Int Int String 45 | 46 | type EthCode = [Operation] 47 | 48 | singleOp::Operation->([Word8]->Operation, Int) 49 | singleOp o = (const o, 1) 50 | 51 | opDatas::[OPData] 52 | opDatas = 53 | [ 54 | OPData 0x00 STOP 0 0 "Halts execution.", 55 | OPData 0x01 ADD 2 1 "Addition operation.", 56 | OPData 0x02 MUL 2 1 "Multiplication operation.", 57 | OPData 0x03 SUB 2 1 "Subtraction operation.", 58 | OPData 0x04 DIV 2 1 "Integer division operation.", 59 | OPData 0x05 SDIV 2 1 "Signed integer division operation.", 60 | OPData 0x06 MOD 2 1 "Modulo remainder operation.", 61 | OPData 0x07 SMOD 2 1 "Signed modulo remainder operation.", 62 | OPData 0x08 ADDMOD 2 1 "unsigned modular addition", 63 | OPData 0x09 MULMOD 2 1 "unsigned modular multiplication", 64 | OPData 0x0a EXP 2 1 "Exponential operation.", 65 | OPData 0x0b SIGNEXTEND 2 1 "Extend length of two’s complement signed integer.", 66 | 67 | OPData 0x10 LT 2 1 "Less-than comparision.", 68 | OPData 0x11 GT 2 1 "Greater-than comparision.", 69 | OPData 0x12 SLT 2 1 "Signed less-than comparision.", 70 | OPData 0x13 SGT 2 1 "Signed greater-than comparision.", 71 | OPData 0x14 EQ 2 1 "Equality comparision.", 72 | OPData 0x15 ISZERO 1 1 "Simple not operator.", 73 | OPData 0x16 AND 2 1 "Bitwise AND operation.", 74 | OPData 0x17 OR 2 1 "Bitwise OR operation.", 75 | OPData 0x18 XOR 2 1 "Bitwise XOR operation.", 76 | OPData 0x19 NOT 1 1 "Bitwise not operator.", 77 | OPData 0x1a BYTE 2 1 "Retrieve single byte from word.", 78 | 79 | OPData 0x20 SHA3 2 1 "Compute SHA3-256 hash.", 80 | 81 | OPData 0x30 ADDRESS 0 1 "Get address of currently executing account.", 82 | OPData 0x31 BALANCE 1 1 "Get balance of the given account.", 83 | OPData 0x32 ORIGIN 0 1 "Get execution origination address.", 84 | OPData 0x33 CALLER 0 1 "Get caller address.", 85 | OPData 0x34 CALLVALUE 0 1 "Get deposited value by the instruction/transaction responsible for this execution.", 86 | OPData 0x35 CALLDATALOAD 1 1 "Get input data of current environment.", 87 | OPData 0x36 CALLDATASIZE 0 1 "Get size of input data in current environment.", 88 | OPData 0x37 CALLDATACOPY 3 0 "Copy input data in current environment to memory.", 89 | OPData 0x38 CODESIZE 0 1 "Get size of code running in current environment.", 90 | OPData 0x39 CODECOPY 3 0 "Copy code running in current environment to memory.", 91 | OPData 0x3a GASPRICE 0 1 "Get price of gas in current environment.", 92 | OPData 0x3b EXTCODESIZE 0 1 "Get size of an account's code.", 93 | OPData 0x3c EXTCODECOPY 0 4 "Copy an account’s code to memory", 94 | 95 | OPData 0x40 BLOCKHASH 0 1 "Get hash of most recent complete block.", 96 | OPData 0x41 COINBASE 0 1 "Get the block’s coinbase address.", 97 | OPData 0x42 TIMESTAMP 0 1 "Get the block’s timestamp.", 98 | OPData 0x43 NUMBER 0 1 "Get the block’s number.", 99 | OPData 0x44 DIFFICULTY 0 1 "Get the block’s difficulty.", 100 | OPData 0x45 GASLIMIT 0 1 "Get the block’s gas limit.", 101 | 102 | OPData 0x50 POP 1 0 "Remove item from stack.", 103 | OPData 0x51 MLOAD 1 1 "Load word from memory.", 104 | OPData 0x52 MSTORE 2 0 "Save word to memory.", 105 | OPData 0x53 MSTORE8 2 0 "Save byte to memory.", 106 | OPData 0x54 SLOAD 1 1 "Load word from storage.", 107 | OPData 0x55 SSTORE 2 0 "Save word to storage.", 108 | OPData 0x56 JUMP 1 0 "Alter the program counter.", 109 | OPData 0x57 JUMPI 2 0 "Conditionally alter the program counter.", 110 | OPData 0x58 PC 0 1 "Get the program counter.", 111 | OPData 0x59 MSIZE 0 1 "Get the size of active memory in bytes.", 112 | OPData 0x5a GAS 0 1 "Get the amount of available gas.", 113 | OPData 0x5b JUMPDEST 0 0 "set a potential jump destination", 114 | 115 | OPData 0x80 DUP1 1 2 "Duplicate 1st stack item.", 116 | OPData 0x81 DUP2 2 3 "Duplicate 2nd stack item.", 117 | OPData 0x82 DUP3 3 4 "Duplicate 3rd stack item.", 118 | OPData 0x83 DUP4 4 5 "Duplicate 4th stack item.", 119 | OPData 0x84 DUP5 5 6 "Duplicate 5th stack item.", 120 | OPData 0x85 DUP6 6 7 "Duplicate 6th stack item.", 121 | OPData 0x86 DUP7 7 8 "Duplicate 7th stack item.", 122 | OPData 0x87 DUP8 8 9 "Duplicate 8th stack item.", 123 | OPData 0x88 DUP9 9 10 "Duplicate 9th stack item.", 124 | OPData 0x89 DUP10 10 11 "Duplicate 10th stack item.", 125 | OPData 0x8a DUP11 11 12 "Duplicate 11th stack item.", 126 | OPData 0x8b DUP12 12 13 "Duplicate 12th stack item.", 127 | OPData 0x8c DUP13 13 14 "Duplicate 13th stack item.", 128 | OPData 0x8d DUP14 14 15 "Duplicate 14th stack item.", 129 | OPData 0x8e DUP15 15 16 "Duplicate 15th stack item.", 130 | OPData 0x8f DUP16 16 17 "Duplicate 16th stack item.", 131 | 132 | OPData 0x90 SWAP1 2 2 "Exchange 1st and 2nd stack items.", 133 | OPData 0x91 SWAP2 3 3 "Exchange 1st and 3nd stack items.", 134 | OPData 0x92 SWAP3 4 4 "Exchange 1st and 4nd stack items.", 135 | OPData 0x93 SWAP4 5 5 "Exchange 1st and 5nd stack items.", 136 | OPData 0x94 SWAP5 6 6 "Exchange 1st and 6nd stack items.", 137 | OPData 0x95 SWAP6 7 7 "Exchange 1st and 7nd stack items.", 138 | OPData 0x96 SWAP7 8 8 "Exchange 1st and 8nd stack items.", 139 | OPData 0x97 SWAP8 9 9 "Exchange 1st and 9nd stack items.", 140 | OPData 0x98 SWAP9 10 10 "Exchange 1st and 10nd stack items.", 141 | OPData 0x99 SWAP10 11 11 "Exchange 1st and 11nd stack items.", 142 | OPData 0x9a SWAP11 12 12 "Exchange 1st and 12nd stack items.", 143 | OPData 0x9b SWAP12 13 13 "Exchange 1st and 13nd stack items.", 144 | OPData 0x9c SWAP13 14 14 "Exchange 1st and 14nd stack items.", 145 | OPData 0x9d SWAP14 15 15 "Exchange 1st and 15nd stack items.", 146 | OPData 0x9e SWAP15 16 16 "Exchange 1st and 16nd stack items.", 147 | OPData 0x9f SWAP16 17 17 "Exchange 1st and 17nd stack items.", 148 | 149 | OPData 0xa0 LOG0 2 0 "Append log record with no topics.", 150 | OPData 0xa1 LOG1 3 0 "Append log record with one topic.", 151 | OPData 0xa2 LOG2 4 0 "Append log record with two topics.", 152 | OPData 0xa3 LOG3 5 0 "Append log record with three topics.", 153 | OPData 0xa4 LOG4 6 0 "Append log record with four topics.", 154 | 155 | OPData 0xf0 CREATE 3 1 "Create a new account with associated code.", 156 | OPData 0xf1 CALL 7 1 "Message-call into an account.", 157 | OPData 0xf2 CALLCODE 7 1 "Message-call into this account with alternate account's code.", 158 | OPData 0xf3 RETURN 2 0 "Halt execution returning output data.", 159 | OPData 0xff SUICIDE 1 0 "Halt execution and register account for later deletion." 160 | ] 161 | 162 | 163 | op2CodeMap::M.Map Operation Word8 164 | op2CodeMap=M.fromList $ (\(OPData code op _ _ _) -> (op, code)) <$> opDatas 165 | 166 | code2OpMap::M.Map Word8 Operation 167 | code2OpMap=M.fromList $ (\(OPData opcode op _ _ _) -> (opcode, op)) <$> opDatas 168 | 169 | op2OpCode::Operation->[Word8] 170 | op2OpCode (PUSH theList) | length theList <= 32 && not (null theList) = 171 | 0x5F + fromIntegral (length theList):theList 172 | op2OpCode (PUSH []) = error "PUSH needs at least one word" 173 | op2OpCode (PUSH x) = error $ "PUSH can only take up to 32 words: " ++ show x 174 | op2OpCode (DATA bytes) = B.unpack bytes 175 | op2OpCode (MalformedOpcode byte) = [byte] 176 | op2OpCode op = 177 | case M.lookup op op2CodeMap of 178 | Just x -> [x] 179 | Nothing -> error $ "op is missing in op2CodeMap: " ++ show op 180 | 181 | opLen::Operation->Int 182 | opLen (PUSH x) = 1 + length x 183 | opLen _ = 1 184 | 185 | opCode2Op::B.ByteString->(Operation, Word256) 186 | opCode2Op rom | B.null rom = (STOP, 1) --according to the yellowpaper, should return STOP if outside of the code bytestring 187 | opCode2Op rom = 188 | let opcode = B.head rom in --head OK, null weeded out above 189 | if opcode >= 0x60 && opcode <= 0x7f 190 | then (PUSH $ B.unpack $ safeTake (fromIntegral $ opcode-0x5F) $ B.tail rom, fromIntegral $ opcode - 0x5E) 191 | else 192 | -- let op = fromMaybe (error $ "code is missing in code2OpMap: 0x" ++ showHex (B.head rom) "") 193 | let op = fromMaybe (MalformedOpcode opcode) 194 | $ M.lookup opcode code2OpMap in 195 | (op, 1) 196 | 197 | 198 | -------------------------------------------------------------------------------- /src/Blockchain/Data/Wire.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.Data.Wire ( 3 | Message(..), 4 | Capability(..), 5 | obj2WireMessage, 6 | wireMessage2Obj 7 | ) where 8 | 9 | import Crypto.Types.PubKey.ECC 10 | import qualified Data.ByteString as B 11 | import Data.Functor 12 | import Data.List 13 | import Data.Word 14 | import Network.Haskoin.Crypto 15 | import Numeric 16 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 17 | 18 | import qualified Blockchain.Colors as CL 19 | import Blockchain.Data.BlockDB 20 | import Blockchain.Data.DataDefs 21 | import Blockchain.Data.Peer 22 | import Blockchain.Data.RLP 23 | import Blockchain.Data.Transaction 24 | import Blockchain.ExtWord 25 | import Blockchain.Format 26 | import Blockchain.SHA 27 | import Blockchain.Util 28 | 29 | --import Debug.Trace 30 | 31 | data Capability = ETH Integer | SHH Integer deriving (Show) 32 | 33 | name2Cap::Integer->String->Capability 34 | name2Cap qqqq "eth" = ETH qqqq 35 | name2Cap qqqq "shh" = SHH qqqq 36 | name2Cap _ x = error $ "Unknown capability string: " ++ x 37 | 38 | {-capValue::Capability->String 39 | capValue ETH = "eth" 40 | capValue SHH = "shh"-} 41 | 42 | instance RLPSerializable Capability where 43 | rlpEncode (ETH qqqq) = RLPArray [rlpEncode "eth", rlpEncode qqqq] 44 | rlpEncode (SHH qqqq) = RLPArray [rlpEncode "shh", rlpEncode qqqq] 45 | 46 | rlpDecode (RLPArray [name, qqqq]) = name2Cap (rlpDecode qqqq) $ rlpDecode name 47 | rlpDecode x = error $ "wrong format given to rlpDecode for Capability: " ++ show (pretty x) 48 | 49 | data TerminationReason = 50 | DisconnectRequested 51 | | TCPSubSystemError 52 | | BreachOfProtocol 53 | | UselessPeer 54 | | TooManyPeers 55 | | AlreadyConnected 56 | | IncompatibleP2PProtocolVersion 57 | | NullNodeIdentityReceived 58 | | ClientQuitting 59 | | UnexpectedIdentity 60 | | ConnectedToSelf 61 | | PingTimeout 62 | | OtherSubprotocolReason deriving (Show) 63 | 64 | 65 | numberToTerminationReason::Integer->TerminationReason 66 | numberToTerminationReason 0x00 = DisconnectRequested 67 | numberToTerminationReason 0x01 = TCPSubSystemError 68 | numberToTerminationReason 0x02 = BreachOfProtocol 69 | numberToTerminationReason 0x03 = UselessPeer 70 | numberToTerminationReason 0x04 = TooManyPeers 71 | numberToTerminationReason 0x05 = AlreadyConnected 72 | numberToTerminationReason 0x06 = IncompatibleP2PProtocolVersion 73 | numberToTerminationReason 0x07 = NullNodeIdentityReceived 74 | numberToTerminationReason 0x08 = ClientQuitting 75 | numberToTerminationReason 0x09 = UnexpectedIdentity 76 | numberToTerminationReason 0x0a = ConnectedToSelf 77 | numberToTerminationReason 0x0b = PingTimeout 78 | numberToTerminationReason 0x0c = OtherSubprotocolReason 79 | numberToTerminationReason _ = error "numberToTerminationReasion called with unsupported number" 80 | 81 | 82 | terminationReasonToNumber::TerminationReason->Integer 83 | terminationReasonToNumber DisconnectRequested = 0x00 84 | terminationReasonToNumber TCPSubSystemError = 0x01 85 | terminationReasonToNumber BreachOfProtocol = 0x02 86 | terminationReasonToNumber UselessPeer = 0x03 87 | terminationReasonToNumber TooManyPeers = 0x04 88 | terminationReasonToNumber AlreadyConnected = 0x05 89 | terminationReasonToNumber IncompatibleP2PProtocolVersion = 0x06 90 | terminationReasonToNumber NullNodeIdentityReceived = 0x07 91 | terminationReasonToNumber ClientQuitting = 0x08 92 | terminationReasonToNumber UnexpectedIdentity = 0x09 93 | terminationReasonToNumber ConnectedToSelf = 0x0a 94 | terminationReasonToNumber PingTimeout = 0x0b 95 | terminationReasonToNumber OtherSubprotocolReason = 0x0c 96 | 97 | 98 | 99 | data Message = 100 | Hello { version::Int, clientId::String, capability::[Capability], port::Int, nodeId::Point } | 101 | Disconnect TerminationReason | 102 | Ping | 103 | Pong | 104 | GetPeers | 105 | Peers [Peer] | 106 | Status { protocolVersion::Int, networkID::String, totalDifficulty::Int, latestHash::SHA, genesisHash:: SHA } | 107 | QqqqStatus Int | 108 | Transactions [Transaction] | 109 | GetBlocks [SHA] | 110 | Blocks [Block] | 111 | BlockHashes [SHA] | 112 | GetBlockHashes { parentSHAs::[SHA], numChildItems::Integer } | 113 | GetTransactions [SHA] | 114 | NewBlockPacket Block Integer | 115 | PacketCount Integer | 116 | QqqqPacket | 117 | WhisperProtocolVersion Int deriving (Show) 118 | 119 | instance Format Point where 120 | format (Point x y) = padZeros 64 (showHex x "") ++ padZeros 64 (showHex y "") 121 | 122 | instance Format Message where 123 | format Hello{version=ver, clientId=c, capability=cap, port=p, nodeId=n} = 124 | CL.blue "Hello" ++ 125 | " version: " ++ show ver ++ "\n" ++ 126 | " cliendId: " ++ show c ++ "\n" ++ 127 | " capability: " ++ intercalate ", " (show <$> cap) ++ "\n" ++ 128 | " port: " ++ show p ++ "\n" ++ 129 | " nodeId: " ++ take 20 (format n) ++ "...." 130 | format (Disconnect reason) = CL.blue "Disconnect" ++ "(" ++ show reason ++ ")" 131 | format Ping = CL.blue "Ping" 132 | format Pong = CL.blue "Pong" 133 | format GetPeers = CL.blue "GetPeers" 134 | format (Peers peers) = CL.blue "Peers: " ++ intercalate ", " (format <$> peers) 135 | format Status{ protocolVersion=ver, networkID=nID, totalDifficulty=d, latestHash=lh, genesisHash=gh } = 136 | CL.blue "Status" ++ 137 | " protocolVersion: " ++ show ver ++ "\n" ++ 138 | " networkID: " ++ show nID ++ "\n" ++ 139 | " totalDifficulty: " ++ show d ++ "\n" ++ 140 | " latestHash: " ++ show (pretty lh) ++ "\n" ++ 141 | " genesisHash: " ++ show (pretty gh) 142 | format (QqqqStatus ver) = 143 | CL.blue "QqqqStatus " ++ 144 | " protocolVersion: " ++ show ver 145 | format (Transactions transactions) = 146 | CL.blue "Transactions:\n " ++ tab (intercalate "\n " (format <$> transactions)) 147 | 148 | --Short version 149 | format (BlockHashes shas) = 150 | CL.blue "BlockHashes " ++ "(" ++ show (length shas) ++ " new hashes)" 151 | --Long version 152 | {- format (BlockHashes shas) = 153 | CL.blue "BlockHashes:" ++ 154 | tab ("\n" ++ intercalate "\n " (show . pretty <$> shas))-} 155 | 156 | format (GetBlocks shas) = 157 | CL.blue "GetBlocks:" ++ 158 | tab ("\n" ++ intercalate "\n " (show . pretty <$> shas)) 159 | format (Blocks blocks) = CL.blue "Blocks:" ++ tab("\n" ++ intercalate "\n " (format <$> blocks)) 160 | format (GetBlockHashes pSHAs numChild) = 161 | CL.blue "GetBlockHashes" ++ " (max: " ++ show numChild ++ "):\n " ++ 162 | intercalate ",\n " (show . pretty <$> pSHAs) 163 | format (NewBlockPacket block d) = CL.blue "NewBlockPacket" ++ " (" ++ show d ++ ")" ++ tab ("\n" ++ format block) 164 | format (PacketCount c) = 165 | CL.blue "PacketCount:" ++ show c 166 | format QqqqPacket = CL.blue "QqqqPacket" 167 | format (GetTransactions transactions) = CL.blue "GetTransactions" ++ tab("\n" ++ intercalate "\n " (show . pretty <$> transactions)) 168 | format (WhisperProtocolVersion ver) = CL.blue "WhisperProtocolVersion " ++ show ver 169 | 170 | 171 | instance RLPSerializable Point where 172 | rlpEncode (Point x y) = 173 | rlpEncode $ B.pack $ (word256ToBytes $ fromInteger x) ++ (word256ToBytes $ fromInteger y) 174 | rlpDecode o = 175 | Point (toInteger $ bytesToWord256 $ B.unpack x) (toInteger $ bytesToWord256 $ B.unpack y) 176 | where 177 | (x, y) = B.splitAt 32 $ rlpDecode o 178 | 179 | obj2WireMessage::Word8->RLPObject->Message 180 | obj2WireMessage 0x0 (RLPArray [ver, cId, RLPArray cap, p, nId]) = 181 | Hello (fromInteger $ rlpDecode ver) (rlpDecode cId) (rlpDecode <$> cap) (fromInteger $ rlpDecode p) (rlpDecode nId) 182 | obj2WireMessage 0x1 (RLPArray [reason]) = 183 | Disconnect (numberToTerminationReason $ rlpDecode reason) 184 | obj2WireMessage 0x2 (RLPArray []) = Ping 185 | obj2WireMessage 0x2 (RLPArray [RLPArray []]) = Ping 186 | obj2WireMessage 0x3 (RLPArray []) = Pong 187 | obj2WireMessage 0x4 (RLPArray []) = GetPeers 188 | obj2WireMessage 0x5 (RLPArray peers) = Peers $ rlpDecode <$> peers 189 | obj2WireMessage 0x10 (RLPArray [ver, nID, d, lh, gh]) = 190 | Status { 191 | protocolVersion=fromInteger $ rlpDecode ver, 192 | networkID = rlpDecode nID, 193 | totalDifficulty = fromInteger $ rlpDecode d, 194 | latestHash=rlpDecode lh, 195 | genesisHash=rlpDecode gh 196 | } 197 | obj2WireMessage 0x10 (RLPArray [ver]) = 198 | QqqqStatus $ fromInteger $ rlpDecode ver 199 | 200 | obj2WireMessage 0x11 (RLPArray transactions) = 201 | GetTransactions $ rlpDecode <$> transactions 202 | obj2WireMessage 0x12 (RLPArray transactions) = 203 | Transactions $ rlpDecode <$> transactions 204 | 205 | 206 | obj2WireMessage 0x13 (RLPArray items) = 207 | GetBlockHashes (rlpDecode <$> init items) $ rlpDecode $ last items 208 | obj2WireMessage 0x14 (RLPArray items) = 209 | BlockHashes $ rlpDecode <$> items 210 | 211 | 212 | obj2WireMessage 0x15 (RLPArray items) = 213 | GetBlocks $ rlpDecode <$> items 214 | obj2WireMessage 0x16 (RLPArray blocks) = 215 | Blocks $ rlpDecode <$> blocks 216 | obj2WireMessage 0x17 (RLPArray [block, td]) = 217 | NewBlockPacket (rlpDecode block) (rlpDecode td) 218 | obj2WireMessage 0x18 (RLPArray [c]) = 219 | PacketCount $ rlpDecode c 220 | obj2WireMessage 0x19 (RLPArray []) = 221 | QqqqPacket 222 | 223 | obj2WireMessage 0x20 (RLPArray [ver]) = 224 | WhisperProtocolVersion $ fromInteger $ rlpDecode ver 225 | 226 | obj2WireMessage x y = error ("Missing case in obj2WireMessage: " ++ show x ++ ", " ++ show (pretty y)) 227 | 228 | 229 | 230 | 231 | 232 | 233 | wireMessage2Obj::Message->(Word8, RLPObject) 234 | wireMessage2Obj Hello { version = ver, 235 | clientId = cId, 236 | capability = cap, 237 | port = p, 238 | nodeId = nId } = 239 | (128, RLPArray [ 240 | rlpEncode $ toInteger ver, 241 | rlpEncode cId, 242 | RLPArray $ rlpEncode <$> cap, 243 | rlpEncode $ toInteger p, 244 | rlpEncode nId 245 | ]) 246 | wireMessage2Obj (Disconnect reason) = (0x0, RLPArray [rlpEncode $ terminationReasonToNumber reason]) 247 | wireMessage2Obj Ping = (0x2, RLPArray []) 248 | wireMessage2Obj Pong = (0x3, RLPArray []) 249 | wireMessage2Obj GetPeers = (0x4, RLPArray []) 250 | wireMessage2Obj (Peers peers) = (0x5, RLPArray $ (rlpEncode <$> peers)) 251 | wireMessage2Obj (Status ver nID d lh gh) = 252 | (0x10, RLPArray [rlpEncode $ toInteger ver, rlpEncode nID, rlpEncode $ toInteger d, rlpEncode lh, rlpEncode gh]) 253 | wireMessage2Obj (QqqqStatus ver) = (0x10, RLPArray [rlpEncode $ toInteger ver]) 254 | wireMessage2Obj (GetTransactions transactions) = (0x11, RLPArray (rlpEncode <$> transactions)) 255 | wireMessage2Obj (Transactions transactions) = (0x12, RLPArray (rlpEncode <$> transactions)) 256 | wireMessage2Obj (GetBlockHashes pSHAs numChildren) = 257 | (0x13, RLPArray $ (rlpEncode <$> pSHAs) ++ [rlpEncode numChildren]) 258 | wireMessage2Obj (BlockHashes shas) = 259 | (0x14, RLPArray (rlpEncode <$> shas)) 260 | wireMessage2Obj (GetBlocks shas) = 261 | (0x15, RLPArray (rlpEncode <$> shas)) 262 | wireMessage2Obj (Blocks blocks) = 263 | (0x16, RLPArray (rlpEncode <$> blocks)) 264 | wireMessage2Obj (NewBlockPacket block d) = 265 | (0x17, RLPArray [rlpEncode block, rlpEncode d]) 266 | wireMessage2Obj (PacketCount c) = 267 | (0x18, RLPArray [rlpEncode c]) 268 | wireMessage2Obj QqqqPacket = 269 | (0x19, RLPArray []) 270 | 271 | wireMessage2Obj (WhisperProtocolVersion ver) = 272 | (0x20, RLPArray [rlpEncode $ toInteger ver]) 273 | 274 | 275 | 276 | -------------------------------------------------------------------------------- /exec_src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main ( 4 | main 5 | ) where 6 | 7 | import Control.Monad.IO.Class 8 | import Control.Monad.State 9 | import Control.Monad.Trans.Resource 10 | import Crypto.PubKey.ECC.DH 11 | import Crypto.Types.PubKey.ECC 12 | import Crypto.Random 13 | import qualified Data.ByteString as B 14 | import Data.Time.Clock 15 | import qualified Network.Haskoin.Internals as H 16 | import Numeric 17 | import System.Entropy 18 | import System.Environment 19 | import System.IO.MMap 20 | 21 | import Blockchain.Frame 22 | import Blockchain.UDP hiding (Ping,Pong) 23 | import Blockchain.RLPx 24 | 25 | import Blockchain.Data.RLP 26 | import Blockchain.BlockChain 27 | import Blockchain.BlockSynchronizer 28 | import Blockchain.Communication 29 | import Blockchain.Constants 30 | import Blockchain.Context 31 | import Blockchain.Data.Address 32 | import Blockchain.Data.BlockDB 33 | import Blockchain.Data.DataDefs 34 | --import Blockchain.Data.SignedTransaction 35 | import Blockchain.Data.Transaction 36 | import Blockchain.Data.Wire 37 | import Blockchain.Database.MerklePatricia 38 | import Blockchain.DB.CodeDB 39 | import Blockchain.DB.ModifyStateDB 40 | import Blockchain.DBM 41 | import Blockchain.Display 42 | import Blockchain.PeerUrls 43 | --import Blockchain.SampleTransactions 44 | import Blockchain.SHA 45 | --import Blockchain.SigningTools 46 | import Blockchain.Util 47 | import qualified Data.ByteString.Base16 as B16 48 | --import Debug.Trace 49 | 50 | import Data.Word 51 | import Data.Bits 52 | import Data.Maybe 53 | import Cache 54 | 55 | coinbasePrvKey::H.PrvKey 56 | Just coinbasePrvKey = H.makePrvKey 0xac3e8ce2ef31c3f45d5da860bcd9aee4b37a05c5a3ddee40dd061620c3dab380 57 | 58 | getNextBlock::Block->UTCTime->[Transaction]->ContextM Block 59 | getNextBlock b ts transactions = do 60 | let theCoinbase = prvKey2Address coinbasePrvKey 61 | lift $ setStateRoot $ blockDataStateRoot bd 62 | addToBalance theCoinbase (1500*finney) 63 | 64 | dbs <- lift get 65 | 66 | return Block{ 67 | blockBlockData=testGetNextBlockData $ SHAPtr "", -- $ stateRoot $ stateDB dbs, 68 | blockReceiptTransactions=transactions, 69 | blockBlockUncles=[] 70 | } 71 | where 72 | testGetNextBlockData::SHAPtr->BlockData 73 | testGetNextBlockData sr = 74 | BlockData { 75 | blockDataParentHash=blockHash b, 76 | blockDataUnclesHash=hash $ B.pack [0xc0], 77 | blockDataCoinbase=prvKey2Address coinbasePrvKey, 78 | blockDataStateRoot = sr, 79 | blockDataTransactionsRoot = emptyTriePtr, 80 | blockDataReceiptsRoot = emptyTriePtr, 81 | blockDataLogBloom = 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], 82 | blockDataDifficulty = nextDifficulty (blockDataDifficulty bd) (blockDataTimestamp bd) ts, 83 | blockDataNumber = blockDataNumber bd + 1, 84 | blockDataGasLimit = blockDataGasLimit bd, -- max 125000 ((blockDataGasLimit bd * 1023 + blockDataGasUsed bd *6 `quot` 5) `quot` 1024), 85 | blockDataGasUsed = 0, 86 | blockDataTimestamp = ts, 87 | blockDataExtraData = 0, 88 | blockDataMixHash = SHA 0, 89 | blockDataNonce = 5 90 | } 91 | bd = blockBlockData b 92 | 93 | 94 | submitNextBlock::Integer->Block->EthCryptM ContextM () 95 | submitNextBlock baseDifficulty b = do 96 | ts <- liftIO getCurrentTime 97 | newBlock <- lift $ getNextBlock b ts [] 98 | n <- liftIO $ fastFindNonce newBlock 99 | 100 | --let theBytes = headerHashWithoutNonce newBlock `B.append` B.pack (integer2Bytes n) 101 | let theNewBlock = addNonceToBlock newBlock n 102 | sendMsg $ NewBlockPacket theNewBlock (baseDifficulty + blockDataDifficulty (blockBlockData theNewBlock)) 103 | lift $ addBlocks False [theNewBlock] 104 | 105 | submitNextBlockToDB::Integer->Block->[Transaction]->EthCryptM ContextM () 106 | submitNextBlockToDB baseDifficulty b transactions = do 107 | ts <- liftIO getCurrentTime 108 | newBlock <- lift $ getNextBlock b ts transactions 109 | --n <- liftIO $ fastFindNonce newBlock 110 | 111 | let theNewBlock = addNonceToBlock newBlock (-1) 112 | lift $ addBlocks True [theNewBlock] 113 | 114 | submitNewBlock::Block->[Transaction]->EthCryptM ContextM () 115 | submitNewBlock b transactions = do 116 | --lift $ addTransactions b (blockDataGasLimit $ blockBlockData b) transactions 117 | submitNextBlockToDB 0 b transactions 118 | 119 | ifBlockInDBSubmitNextBlock::Integer->Block->EthCryptM ContextM () 120 | ifBlockInDBSubmitNextBlock baseDifficulty b = do 121 | maybeBlock <- lift $ lift $ getBlock (blockHash b) 122 | case maybeBlock of 123 | Nothing -> return () 124 | _ -> submitNextBlock baseDifficulty b 125 | 126 | 127 | 128 | handleMsg::Message->EthCryptM ContextM () 129 | handleMsg m = do 130 | lift $ displayMessage False m 131 | case m of 132 | Hello{} -> do 133 | bestBlock <- lift getBestBlock 134 | genesisBlockHash <- lift getGenesisBlockHash 135 | sendMsg Status{ 136 | protocolVersion=fromIntegral ethVersion, 137 | networkID="", 138 | totalDifficulty=0, 139 | latestHash=blockHash bestBlock, 140 | genesisHash=genesisBlockHash 141 | } 142 | Ping -> do 143 | lift addPingCount 144 | sendMsg Pong 145 | GetPeers -> do 146 | sendMsg $ Peers [] 147 | sendMsg GetPeers 148 | (Peers thePeers) -> do 149 | lift $ setPeers thePeers 150 | BlockHashes blockHashes -> handleNewBlockHashes blockHashes 151 | GetBlocks blocks -> do 152 | sendMsg $ Blocks [] 153 | Blocks blocks -> do 154 | handleNewBlocks blocks 155 | NewBlockPacket block baseDifficulty -> do 156 | handleNewBlocks [block] 157 | --ifBlockInDBSubmitNextBlock baseDifficulty block 158 | 159 | Status{latestHash=lh, genesisHash=gh} -> do 160 | genesisBlockHash <- lift getGenesisBlockHash 161 | when (gh /= genesisBlockHash) $ error "Wrong genesis block hash!!!!!!!!" 162 | handleNewBlockHashes [lh] 163 | (GetTransactions transactions) -> do 164 | sendMsg $ Transactions [] 165 | --liftIO $ sendMessage handle GetTransactions 166 | return () 167 | (Transactions transactions) -> do 168 | bestBlock <-lift getBestBlock 169 | submitNewBlock bestBlock transactions 170 | 171 | _-> return () 172 | 173 | readAndOutput::EthCryptM ContextM () 174 | readAndOutput = do 175 | msg <- recvMsg 176 | handleMsg msg 177 | readAndOutput 178 | 179 | mkHello::Point->IO Message 180 | mkHello peerId = do 181 | --let peerId = B.replicate 64 0xFF -- getEntropy 64 182 | let hello = Hello { 183 | version = 4, 184 | clientId = "Ethereum(G)/v0.6.4//linux/Haskell", 185 | capability = [ETH ethVersion], -- , SHH shhVersion], 186 | port = 0, 187 | nodeId = peerId 188 | } 189 | -- putStrLn $ show $ wireMessage2Obj hello 190 | -- putStrLn $ show $ rlpSerialize $ snd (wireMessage2Obj hello) 191 | return hello 192 | {- 193 | createTransaction::Transaction->ContextM SignedTransaction 194 | createTransaction t = do 195 | userNonce <- lift $ addressStateNonce <$> getAddressState (prvKey2Address prvKey) 196 | liftIO $ withSource devURandom $ signTransaction prvKey t{tNonce=userNonce} 197 | 198 | createTransactions::[Transaction]->ContextM [SignedTransaction] 199 | createTransactions transactions = do 200 | userNonce <- lift $ addressStateNonce <$> getAddressState (prvKey2Address prvKey) 201 | forM (zip transactions [userNonce..]) $ \(t, n) -> do 202 | liftIO $ withSource devURandom $ signTransaction prvKey t{tNonce=n} 203 | -} 204 | 205 | intToBytes::Integer->[Word8] 206 | intToBytes x = map (fromIntegral . (x `shiftR`)) [256-8, 256-16..0] 207 | 208 | pointToBytes::Point->[Word8] 209 | pointToBytes (Point x y) = intToBytes x ++ intToBytes y 210 | pointToBytes PointO = error "pointToBytes got value PointO, I don't know what to do here" 211 | 212 | doit::EthCryptM ContextM () 213 | doit = do 214 | liftIO $ putStrLn "Connected" 215 | 216 | lift $ lift $ addCode B.empty --This is probably a bad place to do this, but I can't think of a more natural place to do it.... Empty code is used all over the place, and it needs to be in the database. 217 | lift (lift . setStateRoot . blockDataStateRoot . blockBlockData =<< getBestBlock) 218 | 219 | --signedTx <- createTransaction simpleTX 220 | --signedTx <- createTransaction outOfGasTX 221 | --signedTx <- createTransaction simpleStorageTX 222 | --signedTx <- createTransaction createContractTX 223 | --signedTx <- createTransaction sendMessageTX 224 | 225 | --signedTx <- createTransaction createContractTX 226 | --signedTx <- createTransaction paymentContract 227 | --signedTx <- createTransaction sendCoinTX 228 | --signedTx <- createTransaction keyValuePublisher 229 | --signedTx <- createTransaction sendKeyVal 230 | 231 | --liftIO $ print $ whoSignedThisTransaction signedTx 232 | 233 | 234 | --sendMessage socket $ Transactions [signedTx] 235 | 236 | --signedTxs <- createTransactions [createMysteryContract] 237 | --liftIO $ sendMessage socket $ Transactions signedTxs 238 | 239 | 240 | readAndOutput 241 | 242 | theCurve::Curve 243 | theCurve = getCurveByName SEC_p256k1 244 | 245 | 246 | hPubKeyToPubKey::H.PubKey->Point 247 | hPubKeyToPubKey (H.PubKey hPoint) = Point (fromIntegral x) (fromIntegral y) 248 | where 249 | x = fromMaybe (error "getX failed in prvKey2Address") $ H.getX hPoint 250 | y = fromMaybe (error "getY failed in prvKey2Address") $ H.getY hPoint 251 | hPubKeyToPubKey (H.PubKeyU _) = error "PubKeyU not supported in hPubKeyToPUbKey yet" 252 | 253 | main::IO () 254 | main = do 255 | args <- getArgs 256 | 257 | let (ipAddress, thePort) = 258 | case args of 259 | [] -> ipAddresses !! 1 --default server 260 | [x] -> ipAddresses !! read x 261 | ["-a", address] -> (address, 30303) 262 | [x, prt] -> (fst (ipAddresses !! read x), fromIntegral $ read prt) 263 | ["-a", address, prt] -> (address, fromIntegral $ read prt) 264 | _ -> error "usage: ethereumH [servernum] [port]" 265 | 266 | putStrLn $ "Attempting to connect to " ++ show ipAddress ++ ":" ++ show thePort 267 | 268 | entropyPool <- liftIO createEntropyPool 269 | 270 | let g = cprgCreate entropyPool :: SystemRNG 271 | (myPriv, _) = generatePrivate g $ getCurveByName SEC_p256k1 272 | 273 | let myPublic = calculatePublic theCurve myPriv 274 | -- putStrLn $ "my pubkey is: " ++ show myPublic 275 | putStrLn $ "my pubkey is: " ++ (show $ B16.encode $ B.pack $ pointToBytes myPublic) 276 | 277 | 278 | -- putStrLn $ "my UDP pubkey is: " ++ (show $ H.derivePubKey $ prvKey) 279 | putStrLn $ "my NodeID is: " ++ (show $ B16.encode $ B.pack $ pointToBytes $ hPubKeyToPubKey $ H.derivePubKey $ H.PrvKey $ fromIntegral myPriv) 280 | 281 | otherPubKey@(Point x y) <- liftIO $ getServerPubKey (H.PrvKey $ fromIntegral myPriv) ipAddress thePort 282 | 283 | 284 | -- putStrLn $ "server public key is : " ++ (show otherPubKey) 285 | putStrLn $ "server public key is : " ++ (show $ B16.encode $ B.pack $ pointToBytes otherPubKey) 286 | 287 | --cch <- mkCache 1024 "seed" 288 | 289 | dataset <- return "" -- mmapFileByteString "dataset0" Nothing 290 | 291 | runResourceT $ do 292 | cxt <- openDBs "h" 293 | _ <- flip runStateT cxt $ 294 | flip runStateT (Context [] 0 [] dataset False [] False) $ 295 | runEthCryptM myPriv otherPubKey ipAddress (fromIntegral thePort) $ do 296 | 297 | sendMsg =<< liftIO (mkHello myPublic) 298 | 299 | doit 300 | return () 301 | 302 | -------------------------------------------------------------------------------- /src/Blockchain/SampleTransactions.hs: -------------------------------------------------------------------------------- 1 | 2 | module Blockchain.SampleTransactions where 3 | 4 | import Prelude hiding (EQ) 5 | 6 | import qualified Data.ByteString as B 7 | import Network.Haskoin.Internals hiding (Address) 8 | 9 | import Blockchain.Data.Address 10 | import Blockchain.Data.Code 11 | import Blockchain.Data.Transaction 12 | import Blockchain.Constants 13 | import Blockchain.ExtendedECDSA 14 | import Blockchain.ExtWord 15 | import Blockchain.JCommand 16 | import Blockchain.VM.Code 17 | import Blockchain.VM.Labels 18 | import Blockchain.VM.Opcodes 19 | 20 | --import Debug.Trace 21 | 22 | createContract::Monad m=>Integer->Integer->Code->PrvKey->SecretT m Transaction 23 | createContract val gl code prvKey = 24 | createContractCreationTX 0 0x9184e72a000 gl val code prvKey 25 | 26 | createMessage::Monad m=>Integer->Integer->Address->B.ByteString->PrvKey->SecretT m Transaction 27 | createMessage val gl toAddr theData prvKey = createMessageTX 0 0x9184e72a000 gl toAddr val theData prvKey 28 | 29 | ---------------------- 30 | 31 | simpleTX::Monad m=>PrvKey->SecretT m Transaction 32 | simpleTX = 33 | createContract 0 550 34 | $ compile 35 | [ 36 | PUSH [2], 37 | PUSH [0], 38 | MSTORE, 39 | PUSH [0x20], 40 | PUSH [0], 41 | RETURN 42 | ] 43 | 44 | outOfGasTX::Monad m=>PrvKey->SecretT m Transaction 45 | outOfGasTX = 46 | createContract 3 522 47 | $ compile 48 | [ 49 | PUSH [1], 50 | PUSH [0], 51 | MSTORE 52 | ] 53 | 54 | simpleStorageTX::Monad m=>PrvKey->SecretT m Transaction 55 | simpleStorageTX = 56 | createContract 3 1000 57 | $ compile 58 | [ 59 | PUSH [1], 60 | PUSH [0], 61 | SSTORE 62 | ] 63 | 64 | createInit::[JCommand]->[JCommand]->Code 65 | createInit initFunc contract = -- trace (intercalate "-" $ show <$> contract) $ 66 | -- trace (intercalate "\n " $ fmap show $ snd $ jcompile $ initFunc ++ [ReturnCode contract]) $ do 67 | compile $ lcompile $ snd $ jcompile $ initFunc ++ [ReturnCode $ compile $ lcompile $ snd $ jcompile contract] 68 | 69 | createContractTX::Monad m=>PrvKey->SecretT m Transaction 70 | createContractTX = 71 | createContract (1000*finney) 1000 72 | $ createInit [] 73 | [ 74 | PermStorage (Number 0) :=: Input 0 75 | ] 76 | 77 | sendMessageTX::Monad m=>PrvKey->SecretT m Transaction 78 | sendMessageTX = 79 | createMessage (1000*finney) 1000 (Address 0x9f840fe058ce3d84e319b8c747accc1e52f69426) 80 | (B.pack $ word256ToBytes 0x1234) 81 | 82 | 83 | 84 | paymentContract::Monad m=>PrvKey->SecretT m Transaction 85 | paymentContract = 86 | createContract (1000*finney) 2000 87 | $ createInit 88 | [ 89 | PermStorage Caller :=: Number 1000 90 | ] 91 | ( 92 | let 93 | toAddr = Input (0*32) 94 | fromAddr = Caller 95 | val = Input (1*32) 96 | in 97 | [ 98 | If (PermVal fromAddr :>=: val) 99 | [ 100 | PermStorage fromAddr :=: PermVal fromAddr - val, 101 | PermStorage toAddr :=: PermVal toAddr + val 102 | ] 103 | 104 | ] 105 | ) 106 | 107 | sendCoinTX::Monad m=>PrvKey->SecretT m Transaction 108 | sendCoinTX = 109 | createMessage 0 2000 (Address 0x9f840fe058ce3d84e319b8c747accc1e52f69426) 110 | (B.pack $ word256ToBytes 0x1 ++ word256ToBytes 500) 111 | 112 | 113 | 114 | 115 | keyValuePublisher::Monad m=>PrvKey->SecretT m Transaction 116 | keyValuePublisher = 117 | createContract (1000*finney) 2000 118 | $ createInit 119 | [ 120 | PermStorage 69 :=: Caller 121 | ] 122 | ( 123 | let 124 | inputP = MemStorage (Number 0) 125 | inputPr = MemVal (Number 0) 126 | in 127 | [ 128 | If (Caller :==: PermVal (Number 69)) 129 | [ 130 | While (inputPr :<: CallDataSize) 131 | [ 132 | PermStorage (Input inputPr) :=: Input (inputPr + 32), 133 | inputP :=: inputPr + 64 134 | ] 135 | ] 136 | 137 | ] 138 | ) 139 | 140 | 141 | sendKeyVal::Monad m=>PrvKey->SecretT m Transaction 142 | sendKeyVal prvKey = 143 | createMessage 0 2000 (Address 0x9f840fe058ce3d84e319b8c747accc1e52f69426) 144 | (B.pack $ word256ToBytes 1000 ++ word256ToBytes 2000 ++ word256ToBytes 1234 ++ word256ToBytes 1) 145 | prvKey 146 | 147 | 148 | 149 | {- 150 | 151 | (when (= (caller) @@69) 152 | (for {} (< @i (calldatasize)) [i](+ @i 64) 153 | [[ (calldataload @i) ]] (calldataload (+ @i 32)) 154 | ) 155 | -} 156 | 157 | 158 | 159 | mysteryCode::[Operation] 160 | mysteryCode = 161 | [ 162 | PUSH [3,144], 163 | DUP1, 164 | PUSH [0,14], 165 | PUSH [0], 166 | CODECOPY, 167 | PUSH [3,158], 168 | JUMP, 169 | 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], 170 | PUSH [32], 171 | MSTORE, 172 | PUSH [0], 173 | PUSH [64], 174 | MSTORE, 175 | PUSH [1], 176 | PUSH [96], 177 | MSTORE, 178 | PUSH [2], 179 | PUSH [128], 180 | MSTORE, 181 | PUSH [3], 182 | PUSH [160], 183 | MSTORE, 184 | PUSH [0], 185 | PUSH [192], 186 | MSTORE, 187 | PUSH [1], 188 | PUSH [224], 189 | MSTORE, 190 | PUSH [2], 191 | PUSH [1,0], 192 | MSTORE, 193 | PUSH [0], 194 | PUSH [1,32], 195 | MSTORE, 196 | PUSH [1], 197 | PUSH [1,64], 198 | MSTORE, 199 | PUSH [2], 200 | PUSH [1,96], 201 | MSTORE, 202 | PUSH [3], 203 | PUSH [1,128], 204 | MSTORE, 205 | PUSH [3], 206 | PUSH [1,160], 207 | MSTORE, 208 | PUSH [32], 209 | CALLDATASIZE, 210 | DIV, 211 | PUSH [1,192], 212 | MSTORE, 213 | PUSH [1,160], 214 | MLOAD, 215 | PUSH [1,128], 216 | MLOAD, 217 | ADD, 218 | PUSH [1,192], 219 | MLOAD, 220 | SLT, 221 | ISZERO, 222 | PUSH [0,136], 223 | JUMPI, 224 | PUSH [1,64], 225 | MLOAD, 226 | PUSH [1,224], 227 | MSTORE, 228 | PUSH [32], 229 | PUSH [1,224], 230 | CALLCODE, 231 | JUMPDEST, 232 | PUSH [0], 233 | PUSH [1,128], 234 | MLOAD, 235 | PUSH [1,160], 236 | MLOAD, 237 | PUSH [1,192], 238 | MLOAD, 239 | SUB, 240 | SMOD, 241 | EQ, 242 | ISZERO, 243 | ISZERO, 244 | PUSH [0,174], 245 | JUMPI, 246 | PUSH [1,64], 247 | MLOAD, 248 | PUSH [2,0], 249 | MSTORE, 250 | PUSH [32], 251 | PUSH [2,0], 252 | CALLCODE, 253 | JUMPDEST, 254 | PUSH [1,128], 255 | MLOAD, 256 | PUSH [1,160], 257 | MLOAD, 258 | PUSH [1,192], 259 | MLOAD, 260 | SUB, 261 | SDIV, 262 | PUSH [2,32], 263 | MSTORE, 264 | PUSH [0], 265 | PUSH [2,64], 266 | MSTORE, 267 | PUSH [2], 268 | PUSH [1,160], 269 | MLOAD, 270 | ADD, 271 | PUSH [32], 272 | MUL, 273 | CALLDATALOAD, 274 | PUSH [2,96], 275 | MSTORE, 276 | PUSH [0], 277 | PUSH [2,128], 278 | MSTORE, 279 | JUMPDEST, 280 | PUSH [2,32], 281 | MLOAD, 282 | PUSH [2,64], 283 | MLOAD, 284 | SLT, 285 | ISZERO, 286 | PUSH [1,155], 287 | JUMPI, 288 | PUSH [1], 289 | PUSH [1,160], 290 | MLOAD, 291 | PUSH [1,128], 292 | MLOAD, 293 | PUSH [2,64], 294 | MLOAD, 295 | MUL, 296 | ADD, 297 | ADD, 298 | PUSH [32], 299 | MUL, 300 | CALLDATALOAD, 301 | PUSH [2,160], 302 | MSTORE, 303 | PUSH [2], 304 | PUSH [1,160], 305 | MLOAD, 306 | PUSH [1,128], 307 | MLOAD, 308 | PUSH [2,64], 309 | MLOAD, 310 | MUL, 311 | ADD, 312 | ADD, 313 | PUSH [32], 314 | MUL, 315 | CALLDATALOAD, 316 | PUSH [2,192], 317 | MSTORE, 318 | PUSH [2,96], 319 | MLOAD, 320 | PUSH [2,192], 321 | MLOAD, 322 | EQ, 323 | ISZERO, 324 | ISZERO, 325 | PUSH [1,80], 326 | JUMPI, 327 | PUSH [2,192], 328 | MLOAD, 329 | PUSH [2,96], 330 | MSTORE, 331 | PUSH [0], 332 | PUSH [2,128], 333 | MLOAD, 334 | EQ, 335 | ISZERO, 336 | ISZERO, 337 | PUSH [1,79], 338 | JUMPI, 339 | PUSH [1,96], 340 | MLOAD, 341 | PUSH [2,224], 342 | MSTORE, 343 | PUSH [32], 344 | PUSH [2,224], 345 | CALLCODE, 346 | JUMPDEST, 347 | JUMPDEST, 348 | PUSH [2,160], 349 | MLOAD, 350 | PUSH [2,128], 351 | MLOAD, 352 | ADD, 353 | PUSH [2,128], 354 | MSTORE, 355 | PUSH [1], 356 | PUSH [2,32], 357 | MLOAD, 358 | SUB, 359 | PUSH [2,64], 360 | MLOAD, 361 | EQ, 362 | ISZERO, 363 | PUSH [1,139], 364 | JUMPI, 365 | PUSH [0], 366 | PUSH [2,128], 367 | MLOAD, 368 | EQ, 369 | ISZERO, 370 | ISZERO, 371 | PUSH [1,138], 372 | JUMPI, 373 | PUSH [1,96], 374 | MLOAD, 375 | PUSH [3,0], 376 | MSTORE, 377 | PUSH [32], 378 | PUSH [3,0], 379 | CALLCODE, 380 | JUMPDEST, 381 | JUMPDEST, 382 | PUSH [1], 383 | PUSH [2,64], 384 | MLOAD, 385 | ADD, 386 | PUSH [2,64], 387 | MSTORE, 388 | PUSH [0,220], 389 | JUMP, 390 | JUMPDEST, 391 | PUSH [32], 392 | MLOAD, 393 | SLOAD, 394 | PUSH [3,32], 395 | MSTORE, 396 | PUSH [1], 397 | PUSH [32], 398 | MLOAD, 399 | SLOAD, 400 | ADD, 401 | PUSH [32], 402 | MLOAD, 403 | SSTORE, 404 | PUSH [32], 405 | CALLDATALOAD, 406 | PUSH [3,64], 407 | MSTORE, 408 | PUSH [64], 409 | CALLDATALOAD, 410 | PUSH [3,96], 411 | MSTORE, 412 | PUSH [255,255,255,255,255,255,255,255], 413 | PUSH [3,128], 414 | MSTORE, 415 | PUSH [3,64], 416 | MLOAD, 417 | PUSH [64], 418 | MLOAD, 419 | PUSH [1,0,0,0,0,0,0,0,0], 420 | PUSH [3,128], 421 | MLOAD, 422 | MUL, 423 | PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], 424 | PUSH [3,32], 425 | MLOAD, 426 | MUL, 427 | ADD, 428 | ADD, 429 | SSTORE, 430 | PUSH [3,96], 431 | MLOAD, 432 | PUSH [96], 433 | MLOAD, 434 | PUSH [1,0,0,0,0,0,0,0,0], 435 | PUSH [3,128], 436 | MLOAD, 437 | MUL, 438 | PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], 439 | PUSH [3,32], 440 | MLOAD, 441 | MUL, 442 | ADD, 443 | ADD, 444 | SSTORE, 445 | NUMBER, 446 | PUSH [128], 447 | MLOAD, 448 | PUSH [1,0,0,0,0,0,0,0,0], 449 | PUSH [3,128], 450 | MLOAD, 451 | MUL, 452 | PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], 453 | PUSH [3,32], 454 | MLOAD, 455 | MUL, 456 | ADD, 457 | ADD, 458 | SSTORE, 459 | TIMESTAMP, 460 | PUSH [160], 461 | MLOAD, 462 | PUSH [1,0,0,0,0,0,0,0,0], 463 | PUSH [3,128], 464 | MLOAD, 465 | MUL, 466 | PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], 467 | PUSH [3,32], 468 | MLOAD, 469 | MUL, 470 | ADD, 471 | ADD, 472 | SSTORE, 473 | PUSH [0], 474 | PUSH [2,64], 475 | MSTORE, 476 | JUMPDEST, 477 | PUSH [2,32], 478 | MLOAD, 479 | PUSH [2,64], 480 | MLOAD, 481 | SLT, 482 | ISZERO, 483 | PUSH [3,129], 484 | JUMPI, 485 | PUSH [1,160], 486 | MLOAD, 487 | PUSH [1,128], 488 | MLOAD, 489 | PUSH [2,64], 490 | MLOAD, 491 | MUL, 492 | ADD, 493 | PUSH [32], 494 | MUL, 495 | CALLDATALOAD, 496 | PUSH [3,160], 497 | MSTORE, 498 | PUSH [1], 499 | PUSH [1,160], 500 | MLOAD, 501 | PUSH [1,128], 502 | MLOAD, 503 | PUSH [2,64], 504 | MLOAD, 505 | MUL, 506 | ADD, 507 | ADD, 508 | PUSH [32], 509 | MUL, 510 | CALLDATALOAD, 511 | PUSH [2,160], 512 | MSTORE, 513 | PUSH [2], 514 | PUSH [1,160], 515 | MLOAD, 516 | PUSH [1,128], 517 | MLOAD, 518 | PUSH [2,64], 519 | MLOAD, 520 | MUL, 521 | ADD, 522 | ADD, 523 | PUSH [32], 524 | MUL, 525 | CALLDATALOAD, 526 | PUSH [2,192], 527 | MSTORE, 528 | PUSH [3,160], 529 | MLOAD, 530 | PUSH [192], 531 | MLOAD, 532 | PUSH [1,0,0,0,0,0,0,0,0], 533 | PUSH [2,64], 534 | MLOAD, 535 | MUL, 536 | PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], 537 | PUSH [3,32], 538 | MLOAD, 539 | MUL, 540 | ADD, 541 | ADD, 542 | SSTORE, 543 | PUSH [2,160], 544 | MLOAD, 545 | PUSH [224], 546 | MLOAD, 547 | PUSH [1,0,0,0,0,0,0,0,0], 548 | PUSH [2,64], 549 | MLOAD, 550 | MUL, 551 | PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], 552 | PUSH [3,32], 553 | MLOAD, 554 | MUL, 555 | ADD, 556 | ADD, 557 | SSTORE, 558 | PUSH [2,192], 559 | MLOAD, 560 | PUSH [1,0], 561 | MLOAD, 562 | PUSH [1,0,0,0,0,0,0,0,0], 563 | PUSH [2,64], 564 | MLOAD, 565 | MUL, 566 | PUSH [1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], 567 | PUSH [3,32], 568 | MLOAD, 569 | MUL, 570 | ADD, 571 | ADD, 572 | SSTORE, 573 | PUSH [1], 574 | PUSH [2,64], 575 | MLOAD, 576 | ADD, 577 | PUSH [2,64], 578 | MSTORE, 579 | PUSH [2,138], 580 | JUMP, 581 | JUMPDEST, 582 | PUSH [1,32], 583 | MLOAD, 584 | PUSH [3,192], 585 | MSTORE, 586 | PUSH [32], 587 | PUSH [3,192], 588 | CALLCODE, 589 | JUMPDEST, 590 | PUSH [0], 591 | CALLCODE 592 | ] 593 | 594 | createMysteryContract::Monad m=>PrvKey->SecretT m Transaction 595 | createMysteryContract prvKey = 596 | createContractCreationTX 0 0x9184e72a000 8000 0 (compile mysteryCode) prvKey 597 | -------------------------------------------------------------------------------- /src/Blockchain/BlockChain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, FlexibleContexts #-} 2 | 3 | module Blockchain.BlockChain ( 4 | nextDifficulty, 5 | addBlock, 6 | addBlocks, 7 | addTransaction, 8 | addTransactions, 9 | getBestBlock, 10 | getBestBlockHash, 11 | getGenesisBlockHash, 12 | runCodeForTransaction 13 | ) where 14 | 15 | import Control.Monad 16 | import Control.Monad.IfElse 17 | import Control.Monad.IO.Class 18 | import Control.Monad.Trans 19 | import Control.Monad.Trans.Either 20 | import Control.Monad.State hiding (state) 21 | import Data.Binary hiding (get) 22 | import Data.Bits 23 | import qualified Data.ByteString as B 24 | import qualified Data.ByteString.Base16 as B16 25 | import qualified Data.ByteString.Char8 as BC 26 | import qualified Data.ByteString.Lazy as BL 27 | import Data.Functor 28 | import Data.List 29 | import Data.Maybe 30 | import Data.Time 31 | import Data.Time.Clock 32 | import Data.Time.Clock.POSIX 33 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 34 | import Text.Printf 35 | 36 | import qualified Blockchain.Colors as CL 37 | import Blockchain.Context 38 | import Blockchain.Data.Address 39 | import Blockchain.Data.AddressStateDB 40 | import Blockchain.Data.BlockDB 41 | import Blockchain.Data.Code 42 | import Blockchain.Data.DataDefs 43 | import Blockchain.Data.DiffDB 44 | import Blockchain.Data.GenesisBlock 45 | import Blockchain.Data.RLP 46 | import Blockchain.Data.Transaction 47 | import Blockchain.Data.TransactionResult 48 | import Blockchain.Database.MerklePatricia 49 | import Blockchain.DB.CodeDB 50 | import Blockchain.DB.ModifyStateDB 51 | import Blockchain.DBM 52 | import Blockchain.Constants 53 | import Blockchain.ExtDBs 54 | import Blockchain.Format 55 | import Blockchain.Mining 56 | import Blockchain.SHA 57 | import Blockchain.Util 58 | import Blockchain.VM 59 | import Blockchain.VM.Code 60 | import Blockchain.VM.OpcodePrices 61 | import Blockchain.VM.VMState 62 | 63 | --import Debug.Trace 64 | 65 | {- 66 | initializeBlockChain::ContextM () 67 | initializeBlockChain = do 68 | let bytes = rlpSerialize $ rlpEncode genesisBlock 69 | blockDBPut (BL.toStrict $ encode $ blockHash $ genesisBlock) bytes 70 | detailsDBPut "best" (BL.toStrict $ encode $ blockHash genesisBlock) 71 | -} 72 | 73 | nextDifficulty::Integer->UTCTime->UTCTime->Integer 74 | nextDifficulty oldDifficulty oldTime newTime = max nextDiff' minimumDifficulty 75 | where 76 | nextDiff' = 77 | if round (utcTimeToPOSIXSeconds newTime) >= 78 | (round (utcTimeToPOSIXSeconds oldTime) + 8::Integer) 79 | then oldDifficulty - oldDifficulty `shiftR` 11 80 | else oldDifficulty + oldDifficulty `shiftR` 11 81 | 82 | nextGasLimit::Integer->Integer->Integer 83 | nextGasLimit oldGasLimit oldGasUsed = max (max 125000 3141592) ((oldGasLimit * 1023 + oldGasUsed *6 `quot` 5) `quot` 1024) 84 | 85 | nextGasLimitDelta::Integer->Integer 86 | nextGasLimitDelta oldGasLimit = oldGasLimit `div` 1024 87 | 88 | minGasLimit::Integer 89 | minGasLimit = 125000 90 | 91 | checkUnclesHash::Block->Bool 92 | checkUnclesHash b = blockDataUnclesHash (blockBlockData b) == hash (rlpSerialize $ RLPArray (rlpEncode <$> blockBlockUncles b)) 93 | 94 | --data BlockValidityError = BlockDifficultyWrong Integer Integer | BlockNumberWrong Integer Integer | BlockGasLimitWrong Integer Integer | BlockNonceWrong | BlockUnclesHashWrong 95 | {- 96 | instance Format BlockValidityError where 97 | --format BlockOK = "Block is valid" 98 | format (BlockDifficultyWrong d expected) = "Block difficulty is wrong, is '" ++ show d ++ "', expected '" ++ show expected ++ "'" 99 | -} 100 | 101 | verifyStateRootExists::Block->ContextM Bool 102 | verifyStateRootExists b = do 103 | val <- lift $ stateDBGet (BL.toStrict $ encode $ blockDataStateRoot $ blockBlockData b) 104 | case val of 105 | Nothing -> return False 106 | Just _ -> return True 107 | 108 | checkParentChildValidity::(Monad m)=>Block->Block->m () 109 | checkParentChildValidity Block{blockBlockData=c} Block{blockBlockData=p} = do 110 | unless (blockDataDifficulty c == nextDifficulty (blockDataDifficulty p) (blockDataTimestamp p) (blockDataTimestamp c)) 111 | $ fail $ "Block difficulty is wrong: got '" ++ show (blockDataDifficulty c) ++ "', expected '" ++ show (nextDifficulty (blockDataDifficulty p) (blockDataTimestamp p) (blockDataTimestamp c)) ++ "'" 112 | unless (blockDataNumber c == blockDataNumber p + 1) 113 | $ fail $ "Block number is wrong: got '" ++ show (blockDataNumber c) ++ ", expected '" ++ show (blockDataNumber p + 1) ++ "'" 114 | unless (blockDataGasLimit c <= blockDataGasLimit p + nextGasLimitDelta (blockDataGasLimit p)) 115 | $ fail $ "Block gasLimit is too high: got '" ++ show (blockDataGasLimit c) ++ "', should be less than '" ++ show (blockDataGasLimit p + nextGasLimitDelta (blockDataGasLimit p)) ++ "'" 116 | unless (blockDataGasLimit c >= blockDataGasLimit p - nextGasLimitDelta (blockDataGasLimit p)) 117 | $ fail $ "Block gasLimit is too low: got '" ++ show (blockDataGasLimit c) ++ "', should be less than '" ++ show (blockDataGasLimit p - nextGasLimitDelta (blockDataGasLimit p)) ++ "'" 118 | unless (blockDataGasLimit c >= minGasLimit) 119 | $ fail $ "Block gasLimit is lower than minGasLimit: got '" ++ show (blockDataGasLimit c) ++ "'" 120 | return () 121 | 122 | checkValidity::Monad m=>Block->ContextM (m ()) 123 | checkValidity b = do 124 | maybeParentBlock <- lift $ getBlock (blockDataParentHash $ blockBlockData b) 125 | case maybeParentBlock of 126 | Just parentBlock -> do 127 | checkParentChildValidity b parentBlock 128 | nIsValid <- nonceIsValid' b 129 | --unless nIsValid $ fail $ "Block nonce is wrong: " ++ format b 130 | unless (checkUnclesHash b) $ fail "Block unclesHash is wrong" 131 | stateRootExists <- verifyStateRootExists b 132 | unless stateRootExists $ fail ("Block stateRoot does not exist: " ++ show (pretty $ blockDataStateRoot $ blockBlockData b)) 133 | return $ return () 134 | Nothing -> fail ("Parent Block does not exist: " ++ show (pretty $ blockDataParentHash $ blockBlockData b)) 135 | 136 | 137 | {- 138 | coinbase=prvKey2Address prvKey, 139 | stateRoot = SHA 0x9b109189563315bfeb13d4bfd841b129ff3fd5c85f228a8d9d8563b4dde8432e, 140 | transactionsTrie = 0, 141 | -} 142 | 143 | 144 | runCodeForTransaction::Block->Integer->Address->Address->Transaction->ContextM (Either VMException B.ByteString, VMState) 145 | runCodeForTransaction b availableGas tAddr newAddress ut | isContractCreationTX ut = do 146 | whenM isDebugEnabled $ liftIO $ putStrLn "runCodeForTransaction: ContractCreationTX" 147 | 148 | (result, vmState) <- 149 | create b 0 tAddr tAddr (transactionValue ut) (transactionGasPrice ut) availableGas newAddress (transactionInit ut) 150 | 151 | return (const B.empty <$> result, vmState) 152 | 153 | runCodeForTransaction b availableGas tAddr owner ut | isMessageTX ut = do 154 | whenM isDebugEnabled $ liftIO $ putStrLn $ "runCodeForTransaction: MessageTX caller: " ++ show (pretty $ tAddr) ++ ", address: " ++ show (pretty $ transactionTo ut) 155 | 156 | call b 0 owner owner tAddr 157 | (fromIntegral $ transactionValue ut) (fromIntegral $ transactionGasPrice ut) 158 | (transactionData ut) (fromIntegral availableGas) tAddr 159 | 160 | 161 | 162 | 163 | 164 | addBlocks::Bool->[Block]->ContextM () 165 | addBlocks isBeingCreated blocks = 166 | forM_ blocks $ \block -> do 167 | before <- liftIO $ getPOSIXTime 168 | addBlock isBeingCreated block 169 | after <- liftIO $ getPOSIXTime 170 | 171 | liftIO $ putStrLn $ "#### Block insertion time = " ++ printf "%.4f" (realToFrac $ after - before::Double) ++ "s" 172 | 173 | 174 | isNonceValid::Transaction->ContextM Bool 175 | isNonceValid t = do 176 | case whoSignedThisTransaction t of 177 | Nothing -> return False --no nonce would work 178 | Just tAddr -> do 179 | addressState <- lift $ getAddressState tAddr 180 | return $ addressStateNonce addressState == transactionNonce t 181 | 182 | codeOrDataLength::Transaction->Int 183 | codeOrDataLength t | isMessageTX t = B.length $ transactionData t 184 | codeOrDataLength t | isContractCreationTX t = codeLength $ transactionInit t 185 | 186 | zeroBytesLength::Transaction->Int 187 | zeroBytesLength t | isMessageTX t = length $ filter (==0) $ B.unpack $ transactionData t 188 | zeroBytesLength t | isContractCreationTX t = length $ filter (==0) $ B.unpack codeBytes 189 | where 190 | Code codeBytes = transactionInit t 191 | 192 | intrinsicGas::Transaction->Integer 193 | intrinsicGas t = gTXDATAZERO * zeroLen + gTXDATANONZERO * (fromIntegral (codeOrDataLength t) - zeroLen) + gTX 194 | where 195 | zeroLen = fromIntegral $ zeroBytesLength t 196 | --intrinsicGas t@ContractCreationTX{} = 5 * (fromIntegral (codeOrDataLength t)) + 500 197 | 198 | addTransaction::Block->Integer->Transaction->EitherT String ContextM (VMState, Integer) 199 | addTransaction b remainingBlockGas t = do 200 | let maybeAddr = whoSignedThisTransaction t 201 | 202 | case maybeAddr of 203 | Just x -> return () 204 | Nothing -> left "malformed signature" 205 | 206 | let Just tAddr = maybeAddr 207 | 208 | nonceValid <- lift $ isNonceValid t 209 | 210 | 211 | 212 | let intrinsicGas' = intrinsicGas t 213 | whenM (lift isDebugEnabled) $ 214 | liftIO $ do 215 | putStrLn $ "bytes cost: " ++ show (gTXDATAZERO * (fromIntegral $ zeroBytesLength t) + gTXDATANONZERO * (fromIntegral (codeOrDataLength t) - (fromIntegral $ zeroBytesLength t))) 216 | putStrLn $ "transaction cost: " ++ show gTX 217 | putStrLn $ "intrinsicGas: " ++ show (intrinsicGas') 218 | 219 | addressState <- lift $ lift $ getAddressState tAddr 220 | 221 | when (transactionGasLimit t * transactionGasPrice t + transactionValue t > addressStateBalance addressState) $ left "sender doesn't have high enough balance" 222 | when (intrinsicGas' > transactionGasLimit t) $ left "intrinsic gas higher than transaction gas limit" 223 | when (transactionGasLimit t > remainingBlockGas) $ left "block gas has run out" 224 | when (not nonceValid) $ left "nonce incorrect" 225 | 226 | let availableGas = transactionGasLimit t - intrinsicGas' 227 | 228 | theAddress <- 229 | if isContractCreationTX t 230 | then lift $ getNewAddress tAddr 231 | else do 232 | lift $ incrementNonce tAddr 233 | return $ transactionTo t 234 | 235 | success <- lift $ addToBalance tAddr (-transactionGasLimit t * transactionGasPrice t) 236 | 237 | whenM (lift isDebugEnabled) $ liftIO $ putStrLn "running code" 238 | 239 | if success 240 | then do 241 | (result, newVMState') <- lift $ runCodeForTransaction b (transactionGasLimit t - intrinsicGas') tAddr theAddress t 242 | 243 | lift $ addToBalance (blockDataCoinbase $ blockBlockData b) (transactionGasLimit t * transactionGasPrice t) 244 | 245 | case result of 246 | Left e -> do 247 | whenM (lift isDebugEnabled) $ liftIO $ putStrLn $ CL.red $ show e 248 | return (newVMState'{vmException = Just e}, remainingBlockGas - transactionGasLimit t) 249 | Right x -> do 250 | let realRefund = 251 | min (refund newVMState') ((transactionGasLimit t - vmGasRemaining newVMState') `div` 2) 252 | 253 | success <- lift $ pay "VM refund fees" (blockDataCoinbase $ blockBlockData b) tAddr ((realRefund + vmGasRemaining newVMState') * transactionGasPrice t) 254 | 255 | when (not success) $ error "oops, refund was too much" 256 | 257 | whenM (lift isDebugEnabled) $ liftIO $ putStrLn $ "Removing accounts in suicideList: " ++ intercalate ", " (show . pretty <$> suicideList newVMState') 258 | forM_ (suicideList newVMState') $ lift . lift . deleteAddressState 259 | 260 | 261 | return (newVMState', remainingBlockGas - (transactionGasLimit t - realRefund - vmGasRemaining newVMState')) 262 | else do 263 | lift $ addToBalance (blockDataCoinbase $ blockBlockData b) (intrinsicGas' * transactionGasPrice t) 264 | addressState <- lift $ lift $ getAddressState tAddr 265 | liftIO $ putStrLn $ "Insufficient funds to run the VM: need " ++ show (availableGas*transactionGasPrice t) ++ ", have " ++ show (addressStateBalance addressState) 266 | return (VMState{vmException=Just InsufficientFunds, vmGasRemaining=0, refund=0, debugCallCreates=Nothing, suicideList=[], logs=[], returnVal=Nothing}, remainingBlockGas) 267 | 268 | 269 | printTransactionMessage::Transaction->ContextM () 270 | printTransactionMessage t = do 271 | case whoSignedThisTransaction t of 272 | Just tAddr -> do 273 | nonce <- lift $ fmap addressStateNonce $ getAddressState tAddr 274 | liftIO $ putStrLn $ CL.magenta " ==========================================================================" 275 | liftIO $ putStrLn $ CL.magenta " | Adding transaction signed by: " ++ show (pretty tAddr) ++ CL.magenta " |" 276 | liftIO $ putStrLn $ CL.magenta " | " ++ 277 | ( 278 | if isMessageTX t 279 | then "MessageTX to " ++ show (pretty $ transactionTo t) ++ " " 280 | else "Create Contract " ++ show (pretty $ getNewAddress_unsafe tAddr nonce) 281 | ) ++ CL.magenta " |" 282 | _ -> liftIO $ putStrLn $ CL.red $ "Malformed Signature!" 283 | 284 | formatAddress::Address->String 285 | formatAddress (Address x) = BC.unpack $ B16.encode $ B.pack $ word160ToBytes x 286 | 287 | addTransactions::Block->Integer->[Transaction]->ContextM () 288 | addTransactions _ _ [] = return () 289 | addTransactions b blockGas (t:rest) = do 290 | printTransactionMessage t 291 | 292 | before <- liftIO $ getPOSIXTime 293 | 294 | stateRootBefore <- lift $ getStateRoot 295 | 296 | result <- runEitherT $ addTransaction b blockGas t 297 | 298 | let (resultString, response) = 299 | case result of 300 | Left err -> (err, "") 301 | Right (state, _) -> ("Success!", BC.unpack $ B16.encode $ fromMaybe "" $ returnVal state) 302 | 303 | after <- liftIO $ getPOSIXTime 304 | 305 | stateRootAfter <- lift $ getStateRoot 306 | 307 | mpdb <- fmap stateDB $ lift get 308 | 309 | addrDiff <- lift $ addrDbDiff mpdb stateRootBefore stateRootAfter 310 | 311 | detailsString <- getDebugMsg 312 | lift $ putTransactionResult $ 313 | TransactionResult { 314 | transactionResultBlockHash=blockHash b, 315 | transactionResultTransactionHash=transactionHash t, 316 | transactionResultMessage=resultString, 317 | transactionResultResponse=response, 318 | transactionResultTrace=detailsString, 319 | transactionResultGasUsed=0, 320 | transactionResultEtherUsed=0, 321 | transactionResultContractsCreated=intercalate "," $ map formatAddress [x|CreateAddr x _ <- addrDiff], 322 | transactionResultContractsDeleted=intercalate "," $ map formatAddress [x|DeleteAddr x <- addrDiff], 323 | transactionResultTime=realToFrac $ after - before::Double, 324 | transactionResultNewStorage="", 325 | transactionResultDeletedStorage="" 326 | } 327 | 328 | 329 | clearDebugMsg 330 | 331 | liftIO $ putStrLn $ CL.magenta " |" ++ " t = " ++ printf "%.2f" (realToFrac $ after - before::Double) ++ "s " ++ CL.magenta "|" 332 | liftIO $ putStrLn $ CL.magenta " ==========================================================================" 333 | 334 | remainingBlockGas <- 335 | case result of 336 | Left e -> do 337 | liftIO $ putStrLn $ CL.red "Insertion of transaction failed! " ++ e 338 | return blockGas 339 | Right (_, g') -> return g' 340 | 341 | addTransactions b remainingBlockGas rest 342 | 343 | addBlock::Bool->Block->ContextM () 344 | addBlock isBeingCreated b@Block{blockBlockData=bd, blockBlockUncles=uncles} = do 345 | liftIO $ putStrLn $ "Inserting block #" ++ show (blockDataNumber bd) ++ " (" ++ show (pretty $ blockHash b) ++ ")." 346 | maybeParent <- lift $ getBlock $ blockDataParentHash bd 347 | case maybeParent of 348 | Nothing -> 349 | liftIO $ putStrLn $ "Missing parent block in addBlock: " ++ show (pretty $ blockDataParentHash bd) ++ "\n" ++ 350 | "Block will not be added now, but will be requested and added later" 351 | Just parentBlock -> do 352 | lift $ setStateRoot $ blockDataStateRoot $ blockBlockData parentBlock 353 | let rewardBase = 1500 * finney 354 | addToBalance (blockDataCoinbase bd) rewardBase 355 | 356 | forM_ uncles $ \uncle -> do 357 | addToBalance (blockDataCoinbase bd) (rewardBase `quot` 32) 358 | addToBalance 359 | (blockDataCoinbase uncle) 360 | ((rewardBase*(8+blockDataNumber uncle - blockDataNumber bd )) `quot` 8) 361 | 362 | 363 | let transactions = blockReceiptTransactions b 364 | 365 | addTransactions b (blockDataGasLimit $ blockBlockData b) transactions 366 | 367 | dbs <- lift get 368 | 369 | b' <- 370 | if isBeingCreated 371 | then return b{blockBlockData = (blockBlockData b){blockDataStateRoot=stateRoot $ stateDB dbs}} 372 | else do 373 | when ((blockDataStateRoot (blockBlockData b) /= stateRoot (stateDB dbs))) $ do 374 | liftIO $ putStrLn $ "newStateRoot: " ++ show (pretty $ stateRoot $ stateDB dbs) 375 | error $ "stateRoot mismatch!! New stateRoot doesn't match block stateRoot: " ++ show (pretty $ blockDataStateRoot $ blockBlockData b) 376 | return b 377 | 378 | valid <- checkValidity b' 379 | case valid of 380 | Right () -> return () 381 | Left err -> error err 382 | -- let bytes = rlpSerialize $ rlpEncode b 383 | blkDataId <- lift $ putBlock b' 384 | replaceBestIfBetter (blkDataId, b') 385 | 386 | getBestBlockHash::ContextM SHA 387 | getBestBlockHash = do 388 | maybeBestHash <- lift $ detailsDBGet "best" 389 | case maybeBestHash of 390 | Nothing -> do 391 | bhSHA <- getGenesisBlockHash 392 | lift $ detailsDBPut "best" $ BL.toStrict $ encode bhSHA 393 | return bhSHA 394 | Just bestHash -> return $ decode $ BL.fromStrict $ bestHash 395 | 396 | getGenesisBlockHash::ContextM SHA 397 | getGenesisBlockHash = do 398 | maybeGenesisHash <- lift $ detailsDBGet "genesis" 399 | case maybeGenesisHash of 400 | Nothing -> do 401 | bhSHA <- blockHash <$> initializeGenesisBlock 402 | lift $ detailsDBPut "genesis" $ BL.toStrict $ encode bhSHA 403 | return bhSHA 404 | Just bestHash -> return $ decode $ BL.fromStrict $ bestHash 405 | 406 | getBestBlock::ContextM Block 407 | getBestBlock = do 408 | bestBlockHash <- getBestBlockHash 409 | bestBlock <- lift $ getBlock bestBlockHash 410 | return $ fromMaybe (error $ "Missing block in database: " ++ show (pretty bestBlockHash)) bestBlock 411 | 412 | 413 | replaceBestIfBetter::(BlockDataRefId, Block)->ContextM () 414 | replaceBestIfBetter (blkDataId, b) = do 415 | best <- getBestBlock 416 | if blockDataNumber (blockBlockData best) >= n 417 | then return () 418 | else do 419 | lift $ detailsDBPut "best" (BL.toStrict $ encode $ blockHash b) 420 | let oldStateRoot = blockDataStateRoot (blockBlockData best) 421 | newStateRoot = blockDataStateRoot (blockBlockData b) 422 | lift $ sqlDiff blkDataId n oldStateRoot newStateRoot 423 | where n = blockDataNumber (blockBlockData b) 424 | -------------------------------------------------------------------------------- /src/Blockchain/VM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Blockchain.VM ( 4 | runCodeFromStart, 5 | call, 6 | create 7 | ) where 8 | 9 | import Prelude hiding (LT, GT, EQ) 10 | 11 | import Control.Monad 12 | import Control.Monad.IfElse 13 | import Control.Monad.IO.Class 14 | import Control.Monad.Trans 15 | import Control.Monad.Trans.Either 16 | import Control.Monad.Trans.State 17 | import Data.Bits 18 | import qualified Data.ByteString as B 19 | import Data.Char 20 | import Data.Function 21 | import Data.Functor 22 | import Data.Maybe 23 | import Data.Time.Clock.POSIX 24 | import Numeric 25 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) 26 | 27 | import qualified Blockchain.Colors as CL 28 | import Blockchain.Context 29 | import Blockchain.Data.Address 30 | import Blockchain.Data.AddressStateDB 31 | import Blockchain.Data.BlockDB 32 | import Blockchain.Data.Code 33 | import Blockchain.Data.Log 34 | import Blockchain.DB.CodeDB 35 | import Blockchain.DB.ModifyStateDB 36 | import Blockchain.DBM 37 | import Blockchain.ExtWord 38 | import Blockchain.SHA 39 | import Blockchain.Util 40 | import Blockchain.VM.Code 41 | import Blockchain.VM.Environment 42 | import Blockchain.VM.Memory 43 | import Blockchain.VM.Opcodes 44 | import Blockchain.VM.OpcodePrices 45 | import Blockchain.VM.PrecompiledContracts 46 | import Blockchain.VM.VMM 47 | import Blockchain.VM.VMState 48 | 49 | --import Debug.Trace 50 | 51 | bool2Word256::Bool->Word256 52 | bool2Word256 True = 1 53 | bool2Word256 False = 0 54 | 55 | {- 56 | word2562Bool::Word256->Bool 57 | word2562Bool 1 = True 58 | word2562Bool _ = False 59 | -} 60 | 61 | binaryAction::(Word256->Word256->Word256)->VMM () 62 | binaryAction action = do 63 | x <- pop 64 | y <- pop 65 | push $ x `action` y 66 | 67 | unaryAction::(Word256->Word256)->VMM () 68 | unaryAction action = do 69 | x <- pop 70 | push $ action x 71 | 72 | pushEnvVar::Word256Storable a=>(Environment->a)->VMM () 73 | pushEnvVar f = do 74 | VMState{environment=env} <- lift get 75 | push $ f env 76 | 77 | pushVMStateVar::Word256Storable a=>(VMState->a)->VMM () 78 | pushVMStateVar f = do 79 | state' <- lift get::VMM VMState 80 | push $ f state' 81 | 82 | logN::Int->VMM () 83 | logN n = do 84 | offset <- pop 85 | theSize <- pop 86 | owner <- getEnvVar envOwner 87 | topics' <- sequence $ replicate n pop 88 | 89 | theData <- mLoadByteString offset theSize 90 | addLog Log{address=owner, bloom=0, logData=theData, topics=topics'} 91 | 92 | 93 | 94 | dupN::Int->VMM () 95 | dupN n = do 96 | stack' <- lift $ fmap stack get 97 | if length stack' < n 98 | then do 99 | left StackTooSmallException 100 | else push $ stack' !! (n-1) 101 | 102 | 103 | s256ToInteger::Word256->Integer 104 | --s256ToInteger i | i < 0x7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF = toInteger i 105 | s256ToInteger i | i < 0x8000000000000000000000000000000000000000000000000000000000000000 = toInteger i 106 | s256ToInteger i = toInteger i - 0x10000000000000000000000000000000000000000000000000000000000000000 107 | 108 | 109 | swapn::Int->VMM () 110 | swapn n = do 111 | v1 <- pop 112 | vmState <- lift get 113 | if length (stack vmState) < n 114 | then do 115 | left StackTooSmallException 116 | else do 117 | let (middle, v2:rest2) = splitAt (n-1) $ stack vmState 118 | lift $ put vmState{stack = v2:(middle++(v1:rest2))} 119 | 120 | getByte::Word256->Word256->Word256 121 | getByte whichByte val | whichByte < 32 = val `shiftR` (8*(31 - fromIntegral whichByte)) .&. 0xFF 122 | getByte _ _ = 0; 123 | 124 | signExtend::Word256->Word256->Word256 125 | signExtend numBytes val | numBytes > 31 = val 126 | signExtend numBytes val = baseValue + if highBitSet then highFilter else 0 127 | where 128 | lowFilter = 2^(8*numBytes+8)-1 129 | highFilter = (2^(256::Integer)-1) - lowFilter 130 | baseValue = lowFilter .&. val 131 | highBitSet = val `shiftR` (8*fromIntegral numBytes + 7) .&. 1 == 1 132 | 133 | safe_quot::Integral a=>a->a->a 134 | safe_quot _ 0 = 0 135 | safe_quot x y = x `quot` y 136 | 137 | safe_mod::Integral a=>a->a->a 138 | safe_mod _ 0 = 0 139 | safe_mod x y = x `mod` y 140 | 141 | safe_rem::Integral a=>a->a->a 142 | safe_rem _ 0 = 0 143 | safe_rem x y = x `rem` y 144 | 145 | 146 | --For some strange reason, some ethereum tests (the VMTests) create an account when it doesn't 147 | --exist.... This is a hack to mimic this behavior. 148 | accountCreationHack::Address->VMM () 149 | accountCreationHack address' = do 150 | exists <- lift $ lift $ lift $ addressStateExists address' 151 | when (not exists) $ do 152 | vmState <- lift get 153 | when (not $ isNothing $ debugCallCreates vmState) $ 154 | lift $ lift $ lift $ putAddressState address' blankAddressState 155 | 156 | 157 | 158 | getBlockWithNumber::Integer->Block->VMM (Maybe Block) 159 | getBlockWithNumber num b | num == blockDataNumber (blockBlockData b) = return $ Just b 160 | getBlockWithNumber num b | num > blockDataNumber (blockBlockData b) = return Nothing 161 | getBlockWithNumber num b = do 162 | parentBlock <- lift $ lift $ lift $ getBlock $ blockDataParentHash $ blockBlockData b 163 | getBlockWithNumber num $ 164 | fromMaybe (error "missing parent block in call to getBlockWithNumber") parentBlock 165 | 166 | 167 | 168 | 169 | --TODO- This really should be in its own monad! 170 | --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. 171 | --The code would simplify greatly, but I don't feel motivated to make the change now since things work. 172 | 173 | runOperation::Operation->VMM () 174 | runOperation STOP = do 175 | vmState <- lift get 176 | lift $ put vmState{done=True} 177 | 178 | runOperation ADD = binaryAction (+) 179 | runOperation MUL = binaryAction (*) 180 | runOperation SUB = binaryAction (-) 181 | runOperation DIV = binaryAction safe_quot 182 | runOperation SDIV = binaryAction ((fromIntegral .) . safe_quot `on` s256ToInteger) 183 | runOperation MOD = binaryAction safe_mod 184 | runOperation SMOD = binaryAction ((fromIntegral .) . safe_rem `on` s256ToInteger) --EVM mod corresponds to Haskell rem.... mod and rem only differ in how they handle negative numbers 185 | 186 | runOperation ADDMOD = do 187 | v1 <- pop::VMM Word256 188 | v2 <- pop::VMM Word256 189 | modVal <- pop::VMM Word256 190 | 191 | push $ (toInteger v1 + toInteger v2) `safe_mod` toInteger modVal 192 | 193 | runOperation MULMOD = do 194 | v1 <- pop::VMM Word256 195 | v2 <- pop::VMM Word256 196 | modVal <- pop::VMM Word256 197 | 198 | let ret = (toInteger v1 * toInteger v2) `safe_mod` toInteger modVal 199 | push ret 200 | 201 | 202 | runOperation EXP = binaryAction (^) 203 | runOperation SIGNEXTEND = binaryAction signExtend 204 | 205 | 206 | 207 | runOperation NEG = unaryAction negate 208 | runOperation LT = binaryAction ((bool2Word256 .) . (<)) 209 | runOperation GT = binaryAction ((bool2Word256 .) . (>)) 210 | runOperation SLT = binaryAction ((bool2Word256 .) . ((<) `on` s256ToInteger)) 211 | runOperation SGT = binaryAction ((bool2Word256 .) . ((>) `on` s256ToInteger)) 212 | runOperation EQ = binaryAction ((bool2Word256 .) . (==)) 213 | runOperation ISZERO = unaryAction (bool2Word256 . (==0)) 214 | runOperation AND = binaryAction (.&.) 215 | runOperation OR = binaryAction (.|.) 216 | runOperation XOR = binaryAction xor 217 | 218 | runOperation NOT = unaryAction (0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF `xor`) 219 | 220 | runOperation BYTE = binaryAction getByte 221 | 222 | runOperation SHA3 = do 223 | p <- pop 224 | size <- pop 225 | theData <- unsafeSliceByteString p size 226 | let SHA theHash = hash theData 227 | push $ theHash 228 | 229 | runOperation ADDRESS = pushEnvVar envOwner 230 | 231 | runOperation BALANCE = do 232 | address' <- pop 233 | exists <- lift $ lift $ lift $ addressStateExists address' 234 | if exists 235 | then do 236 | addressState <- lift $ lift $ lift $ getAddressState address' 237 | push $ addressStateBalance addressState 238 | else do 239 | accountCreationHack address' --needed hack to get the tests working 240 | push (0::Word256) 241 | 242 | runOperation ORIGIN = pushEnvVar envOrigin 243 | runOperation CALLER = pushEnvVar envSender 244 | runOperation CALLVALUE = pushEnvVar envValue 245 | 246 | runOperation CALLDATALOAD = do 247 | p <- pop 248 | d <- getEnvVar envInputData 249 | 250 | let val = bytes2Integer $ appendZerosTo32 $ B.unpack $ B.take 32 $ safeDrop p $ d 251 | push val 252 | where 253 | appendZerosTo32 x | length x < 32 = x ++ replicate (32-length x) 0 254 | appendZerosTo32 x = x 255 | 256 | runOperation CALLDATASIZE = pushEnvVar (B.length . envInputData) 257 | 258 | runOperation CALLDATACOPY = do 259 | memP <- pop 260 | codeP <- pop 261 | size <- pop 262 | d <- getEnvVar envInputData 263 | 264 | mStoreByteString memP $ safeTake size $ safeDrop codeP $ d 265 | 266 | runOperation CODESIZE = pushEnvVar (codeLength . envCode) 267 | 268 | runOperation CODECOPY = do 269 | memP <- pop 270 | codeP <- pop 271 | size <- pop 272 | Code c <- getEnvVar envCode 273 | 274 | mStoreByteString memP $ safeTake size $ safeDrop codeP $ c 275 | 276 | runOperation GASPRICE = pushEnvVar envGasPrice 277 | 278 | 279 | runOperation EXTCODESIZE = do 280 | address' <- pop 281 | accountCreationHack address' --needed hack to get the tests working 282 | addressState <- lift $ lift $ lift $ getAddressState address' 283 | code <- lift $ lift $ lift $ fromMaybe B.empty <$> getCode (addressStateCodeHash addressState) 284 | push $ (fromIntegral (B.length code)::Word256) 285 | 286 | runOperation EXTCODECOPY = do 287 | address' <- pop 288 | accountCreationHack address' --needed hack to get the tests working 289 | memOffset <- pop 290 | codeOffset <- pop 291 | size <- pop 292 | 293 | addressState <- lift $ lift $ lift $ getAddressState address' 294 | code <- lift $ lift $ lift $ fromMaybe B.empty <$> getCode (addressStateCodeHash addressState) 295 | mStoreByteString memOffset (safeTake size $ safeDrop codeOffset $ code) 296 | push $ (fromIntegral (B.length code)::Word256) 297 | 298 | runOperation BLOCKHASH = do 299 | number' <- pop::VMM Word256 300 | 301 | currentBlock <- getEnvVar envBlock 302 | let currentBlockNumber = blockDataNumber . blockBlockData $ currentBlock 303 | 304 | if toInteger number' >= currentBlockNumber || toInteger number' < currentBlockNumber - 256 305 | then push (0::Word256) 306 | else do 307 | maybeBlock <- getBlockWithNumber (fromIntegral number') currentBlock 308 | --let SHA h = hash $ BC.pack $ show $ toInteger number' 309 | case maybeBlock of 310 | Nothing -> push (0::Word256) 311 | Just theBlock -> push $ blockHash theBlock 312 | 313 | runOperation COINBASE = pushEnvVar (blockDataCoinbase . blockBlockData . envBlock) 314 | runOperation TIMESTAMP = do 315 | VMState{environment=env} <- lift get 316 | push $ ((round . utcTimeToPOSIXSeconds . blockDataTimestamp . blockBlockData . envBlock) env::Word256) 317 | 318 | 319 | 320 | runOperation NUMBER = pushEnvVar (blockDataNumber . blockBlockData . envBlock) 321 | runOperation DIFFICULTY = pushEnvVar (blockDataDifficulty . blockBlockData . envBlock) 322 | runOperation GASLIMIT = pushEnvVar (blockDataGasLimit . blockBlockData . envBlock) 323 | 324 | runOperation POP = do 325 | _ <- pop::VMM Word256 326 | return () 327 | 328 | runOperation LOG0 = logN 0 329 | runOperation LOG1 = logN 1 330 | runOperation LOG2 = logN 2 331 | runOperation LOG3 = logN 3 332 | runOperation LOG4 = logN 4 333 | 334 | runOperation MLOAD = do 335 | p <- pop 336 | bytes <- mLoad p 337 | push $ (fromInteger (bytes2Integer bytes)::Word256) 338 | 339 | runOperation MSTORE = do 340 | p <- pop 341 | val <- pop 342 | mStore p val 343 | 344 | runOperation MSTORE8 = do 345 | p <- pop 346 | val <- pop::VMM Word256 347 | mStore8 p (fromIntegral $ val .&. 0xFF) 348 | 349 | runOperation SLOAD = do 350 | p <- pop 351 | val <- getStorageKeyVal p 352 | push val 353 | 354 | runOperation SSTORE = do 355 | p <- pop 356 | val <- pop::VMM Word256 357 | 358 | if val == 0 359 | then deleteStorageKey p 360 | else putStorageKeyVal p val 361 | 362 | --TODO- refactor so that I don't have to use this -1 hack 363 | runOperation JUMP = do 364 | p <- pop 365 | jumpDests <- getEnvVar envJumpDests 366 | 367 | if p `elem` jumpDests 368 | then setPC $ fromIntegral p - 1 -- Subtracting 1 to compensate for the pc-increment that occurs every step. 369 | else left InvalidJump 370 | 371 | runOperation JUMPI = do 372 | p <- pop 373 | condition <- pop 374 | jumpDests <- getEnvVar envJumpDests 375 | 376 | case (p `elem` jumpDests, (0::Word256) /= condition) of 377 | (_, False) -> return () 378 | (True, _) -> setPC $ fromIntegral p - 1 379 | _ -> left InvalidJump 380 | 381 | runOperation PC = pushVMStateVar pc 382 | 383 | runOperation MSIZE = do 384 | memSize <- getSizeInBytes 385 | push memSize 386 | 387 | runOperation GAS = pushVMStateVar vmGasRemaining 388 | 389 | runOperation JUMPDEST = return () 390 | 391 | runOperation (PUSH vals) = 392 | push $ (fromIntegral (bytes2Integer vals)::Word256) 393 | 394 | runOperation DUP1 = dupN 1 395 | runOperation DUP2 = dupN 2 396 | runOperation DUP3 = dupN 3 397 | runOperation DUP4 = dupN 4 398 | runOperation DUP5 = dupN 5 399 | runOperation DUP6 = dupN 6 400 | runOperation DUP7 = dupN 7 401 | runOperation DUP8 = dupN 8 402 | runOperation DUP9 = dupN 9 403 | runOperation DUP10 = dupN 10 404 | runOperation DUP11 = dupN 11 405 | runOperation DUP12 = dupN 12 406 | runOperation DUP13 = dupN 13 407 | runOperation DUP14 = dupN 14 408 | runOperation DUP15 = dupN 15 409 | runOperation DUP16 = dupN 16 410 | 411 | runOperation SWAP1 = swapn 1 412 | runOperation SWAP2 = swapn 2 413 | runOperation SWAP3 = swapn 3 414 | runOperation SWAP4 = swapn 4 415 | runOperation SWAP5 = swapn 5 416 | runOperation SWAP6 = swapn 6 417 | runOperation SWAP7 = swapn 7 418 | runOperation SWAP8 = swapn 8 419 | runOperation SWAP9 = swapn 9 420 | runOperation SWAP10 = swapn 10 421 | runOperation SWAP11 = swapn 11 422 | runOperation SWAP12 = swapn 12 423 | runOperation SWAP13 = swapn 13 424 | runOperation SWAP14 = swapn 14 425 | runOperation SWAP15 = swapn 15 426 | runOperation SWAP16 = swapn 16 427 | 428 | runOperation CREATE = do 429 | value <- pop::VMM Word256 430 | input <- pop 431 | size <- pop 432 | 433 | owner <- getEnvVar envOwner 434 | block <- getEnvVar envBlock 435 | 436 | initCodeBytes <- unsafeSliceByteString input size 437 | 438 | vmState <- lift get 439 | 440 | callDepth' <- getCallDepth 441 | 442 | result <- 443 | case (callDepth' > 1023, debugCallCreates vmState) of 444 | (True, _) -> return Nothing 445 | (_, Nothing) -> create_debugWrapper block owner value initCodeBytes 446 | (_, Just _) -> do 447 | addressState' <- lift $ lift $ lift $ getAddressState owner 448 | 449 | let newAddress = getNewAddress_unsafe owner $ addressStateNonce addressState' 450 | 451 | if addressStateBalance addressState' < fromIntegral value 452 | then return Nothing 453 | else do 454 | addToBalance' owner (-fromIntegral value) 455 | addDebugCallCreate DebugCallCreate { 456 | ccData=initCodeBytes, 457 | ccDestination=Nothing, 458 | ccGasLimit=vmGasRemaining vmState, 459 | ccValue=fromIntegral value 460 | } 461 | return $ Just newAddress 462 | 463 | case result of 464 | Just address' -> push address' 465 | Nothing -> push (0::Word256) 466 | 467 | runOperation CALL = do 468 | gas <- pop::VMM Word256 469 | to <- pop 470 | value <- pop::VMM Word256 471 | inOffset <- pop 472 | inSize <- pop 473 | outOffset <- pop 474 | outSize <- pop::VMM Word256 475 | 476 | owner <- getEnvVar envOwner 477 | 478 | inputData <- unsafeSliceByteString inOffset inSize 479 | _ <- unsafeSliceByteString outOffset outSize --needed to charge for memory 480 | 481 | vmState <- lift get 482 | 483 | let stipend = if value > 0 then fromIntegral gCALLSTIPEND else 0 484 | 485 | addressState <- lift $ lift $ lift $ getAddressState owner 486 | 487 | callDepth' <- getCallDepth 488 | 489 | (result, maybeBytes) <- 490 | case (callDepth' > 1023, fromIntegral value > addressStateBalance addressState, debugCallCreates vmState) of 491 | (True, _, _) -> do 492 | liftIO $ putStrLn $ CL.red "Call stack too deep." 493 | addGas $ fromIntegral gas 494 | return (0, Nothing) 495 | (_, True, _) -> do 496 | liftIO $ putStrLn $ CL.red "Not enough ether to transfer the value." 497 | addGas $ fromIntegral $ gas + fromIntegral stipend 498 | return (0, Nothing) 499 | (_, _, Nothing) -> do 500 | nestedRun_debugWrapper (fromIntegral gas + stipend) to to owner value inputData 501 | (_, _, Just _) -> do 502 | addGas $ fromIntegral stipend 503 | addToBalance' owner (-fromIntegral value) 504 | addGas $ fromIntegral gas 505 | addDebugCallCreate DebugCallCreate { 506 | ccData=inputData, 507 | ccDestination=Just to, 508 | ccGasLimit=fromIntegral gas + stipend, 509 | ccValue=fromIntegral value 510 | } 511 | return (1, Nothing) 512 | 513 | case maybeBytes of 514 | Nothing -> return () 515 | Just bytes -> mStoreByteString outOffset bytes 516 | 517 | push result 518 | 519 | runOperation CALLCODE = do 520 | 521 | gas <- pop::VMM Word256 522 | to <- pop 523 | value <- pop::VMM Word256 524 | inOffset <- pop 525 | inSize <- pop 526 | outOffset <- pop 527 | outSize <- pop::VMM Word256 528 | 529 | owner <- getEnvVar envOwner 530 | 531 | inputData <- unsafeSliceByteString inOffset inSize 532 | _ <- unsafeSliceByteString outOffset outSize --needed to charge for memory 533 | 534 | vmState <- lift get 535 | 536 | let stipend = if value > 0 then fromIntegral gCALLSTIPEND else 0 537 | 538 | -- toAddressExists <- lift $ lift $ lift $ addressStateExists to 539 | 540 | -- let newAccountCost = if not toAddressExists then gCALLNEWACCOUNT else 0 541 | 542 | -- useGas $ fromIntegral newAccountCost 543 | 544 | addressState <- lift $ lift $ lift $ getAddressState owner 545 | 546 | 547 | callDepth' <- getCallDepth 548 | 549 | (result, maybeBytes) <- 550 | case (callDepth' > 1023, fromIntegral value > addressStateBalance addressState, debugCallCreates vmState) of 551 | (True, _, _) -> do 552 | addGas $ fromIntegral gas 553 | return (0, Nothing) 554 | (_, True, _) -> do 555 | addGas $ fromIntegral gas 556 | addGas $ fromIntegral stipend 557 | whenM (lift $ lift isDebugEnabled) $ liftIO $ putStrLn $ CL.red "Insufficient balance" 558 | return (0, Nothing) 559 | (_, _, Nothing) -> do 560 | nestedRun_debugWrapper (fromIntegral gas+stipend) owner to owner value inputData 561 | (_, _, Just _) -> do 562 | addToBalance' owner (-fromIntegral value) 563 | addGas $ fromIntegral stipend 564 | addGas $ fromIntegral gas 565 | addDebugCallCreate DebugCallCreate { 566 | ccData=inputData, 567 | ccDestination=Just $ owner, 568 | ccGasLimit=fromIntegral gas + stipend, 569 | ccValue=fromIntegral value 570 | } 571 | return (1, Nothing) 572 | 573 | case maybeBytes of 574 | Nothing -> return () 575 | Just bytes -> mStoreByteString outOffset bytes 576 | 577 | push result 578 | 579 | runOperation RETURN = do 580 | address' <- pop 581 | size <- pop 582 | 583 | --retVal <- mLoadByteString address' size 584 | retVal <- unsafeSliceByteString address' size 585 | setDone True 586 | setReturnVal $ Just retVal 587 | 588 | runOperation SUICIDE = do 589 | address' <- pop 590 | owner <- getEnvVar envOwner 591 | addressState <- lift $ lift $ lift $ getAddressState $ owner 592 | 593 | let allFunds = addressStateBalance addressState 594 | pay' "transferring all funds upon suicide" owner address' allFunds 595 | addSuicideList owner 596 | setDone True 597 | 598 | 599 | runOperation (MalformedOpcode opcode) = do 600 | whenM (lift $ lift isDebugEnabled) $ liftIO $ putStrLn $ CL.red ("Malformed Opcode: " ++ showHex opcode "") 601 | left MalformedOpcodeException 602 | 603 | runOperation x = error $ "Missing case in runOperation: " ++ show x 604 | 605 | ------------------- 606 | 607 | opGasPriceAndRefund::Operation->VMM (Integer, Integer) 608 | 609 | opGasPriceAndRefund LOG0 = do 610 | size <- getStackItem 1::VMM Word256 611 | return (gLOG + gLOGDATA * fromIntegral size, 0) 612 | opGasPriceAndRefund LOG1 = do 613 | size <- getStackItem 1::VMM Word256 614 | return (gLOG + gLOGTOPIC + gLOGDATA * fromIntegral size, 0) 615 | opGasPriceAndRefund LOG2 = do 616 | size <- getStackItem 1::VMM Word256 617 | return (gLOG + 2*gLOGTOPIC + gLOGDATA * fromIntegral size, 0) 618 | opGasPriceAndRefund LOG3 = do 619 | size <- getStackItem 1::VMM Word256 620 | return (gLOG + 3*gLOGTOPIC + gLOGDATA * fromIntegral size, 0) 621 | opGasPriceAndRefund LOG4 = do 622 | size <- getStackItem 1::VMM Word256 623 | return (gLOG + 4*gLOGTOPIC + gLOGDATA * fromIntegral size, 0) 624 | 625 | opGasPriceAndRefund SHA3 = do 626 | size <- getStackItem 1::VMM Word256 627 | return (30+6*ceiling(fromIntegral size/(32::Double)), 0) 628 | 629 | opGasPriceAndRefund EXP = do 630 | e <- getStackItem 1::VMM Word256 631 | if e == 0 632 | then return (gEXPBASE, 0) 633 | else return (gEXPBASE + gEXPBYTE*bytesNeeded e, 0) 634 | 635 | where 636 | bytesNeeded::Word256->Integer 637 | bytesNeeded 0 = 0 638 | bytesNeeded x = 1+bytesNeeded (x `shiftR` 8) 639 | 640 | 641 | opGasPriceAndRefund CALL = do 642 | gas <- getStackItem 0::VMM Word256 643 | to <- getStackItem 1::VMM Word256 644 | val <- getStackItem 2::VMM Word256 645 | 646 | toAccountExists <- lift $ lift $ lift $ addressStateExists $ Address $ fromIntegral to 647 | 648 | return $ ( 649 | fromIntegral gas + 650 | fromIntegral gCALL + 651 | (if toAccountExists then 0 else fromIntegral gCALLNEWACCOUNT) + 652 | -- (if toAccountExists || to < 5 then 0 else gCALLNEWACCOUNT) + 653 | (if val > 0 then fromIntegral gCALLVALUETRANSFER else 0), 654 | 0) 655 | 656 | 657 | opGasPriceAndRefund CALLCODE = do 658 | gas <- getStackItem 0::VMM Word256 659 | -- to <- getStackItem 1::VMM Word256 660 | val <- getStackItem 2::VMM Word256 661 | 662 | -- toAccountExists <- lift $ lift $ lift $ addressStateExists $ Address $ fromIntegral to 663 | 664 | return $ (fromIntegral $ 665 | fromIntegral gas + 666 | fromIntegral gCALL + 667 | -- (if toAccountExists then 0 else gCALLNEWACCOUNT) + 668 | (if val > 0 then gCALLVALUETRANSFER else 0), 669 | 0) 670 | 671 | 672 | opGasPriceAndRefund CODECOPY = do 673 | size <- getStackItem 2::VMM Word256 674 | return (gCODECOPYBASE + gCOPYWORD * ceiling (fromIntegral size / (32::Double)), 0) 675 | opGasPriceAndRefund CALLDATACOPY = do 676 | size <- getStackItem 2::VMM Word256 677 | return (gCALLDATACOPYBASE + gCOPYWORD * ceiling (fromIntegral size / (32::Double)), 0) 678 | opGasPriceAndRefund EXTCODECOPY = do 679 | size <- getStackItem 3::VMM Word256 680 | return (gEXTCODECOPYBASE + gCOPYWORD * ceiling (fromIntegral size / (32::Double)), 0) 681 | opGasPriceAndRefund SSTORE = do 682 | p <- getStackItem 0 683 | val <- getStackItem 1 684 | oldVal <- getStorageKeyVal p 685 | case (oldVal, val) of 686 | (0, x) | x /= (0::Word256) -> return (20000, 0) 687 | (x, 0) | x /= 0 -> return (5000, 15000) 688 | _ -> return (5000, 0) 689 | opGasPriceAndRefund SUICIDE = return (0, 24000) 690 | 691 | {-opGasPriceAndRefund RETURN = do 692 | size <- getStackItem 1 693 | 694 | return (gTXDATANONZERO*size, 0)-} 695 | 696 | opGasPriceAndRefund x = return (opGasPrice x, 0) 697 | 698 | --missing stuff 699 | --Glog 1 Partial payment for a LOG operation. 700 | --Glogdata 1 Paid for each byte in a LOG operation’s data. 701 | --Glogtopic 1 Paid for each topic of a LOG operation. 702 | 703 | formatOp::Operation->String 704 | formatOp (PUSH x) = "PUSH" ++ show (length x) -- ++ show x 705 | formatOp x = show x 706 | 707 | 708 | printDebugInfo::Environment->Word256->Word256->Int->Operation->VMState->VMState->VMM () 709 | printDebugInfo env memBefore memAfter c op stateBefore stateAfter = do 710 | liftIO $ putStrLn $ "EVM [ eth | " ++ show (callDepth stateBefore) ++ " | " ++ formatAddressWithoutColor (envOwner env) ++ " | #" ++ show c ++ " | " ++ map toUpper (showHex4 (pc stateBefore)) ++ " : " ++ formatOp op ++ " | " ++ show (vmGasRemaining stateBefore) ++ " | " ++ show (vmGasRemaining stateAfter - vmGasRemaining stateBefore) ++ " | " ++ show(toInteger memAfter - toInteger memBefore) ++ "x32 ]" 711 | 712 | liftIO $ putStrLn $ "EVM [ eth ] " 713 | memByteString <- liftIO $ getMemAsByteString (memory stateAfter) 714 | liftIO $ putStrLn " STACK" 715 | liftIO $ putStr $ unlines (padZeros 64 <$> flip showHex "" <$> (reverse $ stack stateAfter)) 716 | liftIO $ putStr $ " MEMORY\n" ++ showMem 0 (B.unpack $ memByteString) 717 | liftIO $ putStrLn $ " STORAGE" 718 | kvs <- getAllStorageKeyVals 719 | liftIO $ putStrLn $ unlines (map (\(k, v) -> "0x" ++ showHexU (byteString2Integer $ nibbleString2ByteString k) ++ ": 0x" ++ showHexU (fromIntegral v)) kvs) 720 | 721 | 722 | runCode::Int->VMM () 723 | runCode c = do 724 | memBefore <- getSizeInWords 725 | code <- getEnvVar envCode 726 | 727 | vmState <- lift get 728 | 729 | let (op, len) = getOperationAt code (pc vmState) 730 | --liftIO $ putStrLn $ "EVM [ 19:22" ++ show op ++ " #" ++ show c ++ " (" ++ show (vmGasRemaining state) ++ ")" 731 | 732 | (val, theRefund) <- opGasPriceAndRefund op 733 | 734 | useGas val 735 | addToRefund theRefund 736 | 737 | runOperation op 738 | 739 | memAfter <- getSizeInWords 740 | 741 | result <- lift get 742 | 743 | env <- lift $ fmap environment get 744 | 745 | lift $ lift $ addDebugMsg $ 746 | "EVM [ eth | " ++ show (callDepth vmState) ++ " | " ++ formatAddressWithoutColor (envOwner env) ++ " | #" ++ show c ++ " | " ++ map toUpper (showHex4 (pc vmState)) ++ " : " ++ formatOp op ++ " | " ++ show (vmGasRemaining vmState) ++ " | " ++ show (vmGasRemaining result - vmGasRemaining result) ++ " | " ++ show(toInteger memAfter - toInteger memBefore) ++ "x32 ]\n" 747 | 748 | whenM (lift $ lift isDebugEnabled) $ printDebugInfo (environment result) memBefore memAfter c op vmState result 749 | 750 | case result of 751 | VMState{done=True} -> incrementPC len 752 | _ -> do 753 | incrementPC len 754 | runCode (c+1) 755 | 756 | runCodeFromStart::VMM () 757 | runCodeFromStart = do 758 | env <- lift $ fmap environment get 759 | 760 | whenM (lift $ lift isDebugEnabled) $ liftIO $ putStrLn $ "running code: " ++ tab (CL.magenta ("\n" ++ show (pretty $ envCode env))) 761 | 762 | runCode 0 763 | 764 | runVMM::Int->Environment->Integer->VMM a->ContextM (Either VMException a, VMState) 765 | runVMM callDepth' env availableGas f = do 766 | vmState <- liftIO $ startingState env 767 | 768 | cxtBefore <- lift get 769 | result <- 770 | flip runStateT vmState{callDepth=callDepth', vmGasRemaining=availableGas} $ 771 | runEitherT f 772 | 773 | case result of 774 | (Left e, _) -> do 775 | liftIO $ putStrLn $ CL.red $ "Exception caught (" ++ show e ++ "), reverting state" 776 | cxtAfter <- lift get 777 | lift $ put cxtAfter{stateDB=stateDB cxtBefore} 778 | _ -> return () 779 | 780 | 781 | whenM isDebugEnabled $ liftIO $ putStrLn "VM has finished running" 782 | 783 | return result 784 | 785 | --bool Executive::create(Address _sender, u256 _endowment, u256 _gasPrice, u256 _gas, bytesConstRef _init, Address _origin) 786 | 787 | create::Block->Int->Address->Address->Integer->Integer->Integer->Address->Code->ContextM (Either VMException Code, VMState) 788 | create b callDepth' sender origin value' gasPrice' availableGas newAddress init' = do 789 | let env = 790 | Environment{ 791 | envGasPrice=gasPrice', 792 | envBlock=b, 793 | envOwner = newAddress, 794 | envOrigin = origin, 795 | envInputData = B.empty, 796 | envSender = sender, 797 | envValue = value', 798 | envCode = init', 799 | envJumpDests = getValidJUMPDESTs init' 800 | } 801 | 802 | vmState <- liftIO $ startingState env 803 | 804 | success <- 805 | if toInteger value' > 0 806 | then do 807 | --This next line will actually create the account addressState data.... 808 | --In the extremely unlikely even that the address already exists, it will preserve 809 | --the existing balance. 810 | pay "transfer value" sender newAddress $ fromIntegral value' 811 | else return True 812 | 813 | ret <- 814 | if success 815 | then runVMM callDepth' env availableGas create' 816 | else return (Left InsufficientFunds, vmState) 817 | 818 | 819 | case ret of 820 | (Left _, _) -> do 821 | --if there was an error, addressStates were reverted, so the receiveAddress still should 822 | --have the value, and I can revert without checking for success. 823 | _ <- pay "revert value transfer" newAddress sender (fromIntegral value') 824 | lift $ deleteAddressState newAddress 825 | return ret 826 | _ -> return ret 827 | 828 | 829 | 830 | create'::VMM Code 831 | create' = do 832 | 833 | runCodeFromStart 834 | 835 | vmState <- lift get 836 | 837 | owner <- getEnvVar envOwner 838 | 839 | let codeBytes' = fromMaybe B.empty $ returnVal vmState 840 | whenM (lift $ lift isDebugEnabled) $ liftIO $ putStrLn $ "Result: " ++ show codeBytes' 841 | 842 | 843 | if vmGasRemaining vmState < gCREATEDATA * toInteger (B.length codeBytes') 844 | then do 845 | liftIO $ putStrLn $ CL.red "Not enough ether to create contract, contract being thrown away (account was created though)" 846 | assignCode "" owner 847 | return $ Code "" 848 | else do 849 | useGas $ gCREATEDATA * toInteger (B.length codeBytes') 850 | assignCode codeBytes' owner 851 | return $ Code codeBytes' 852 | 853 | where 854 | assignCode::B.ByteString->Address->VMM () 855 | assignCode codeBytes' address' = do 856 | lift $ lift $ lift $ addCode codeBytes' 857 | newAddressState <- lift $ lift $ lift $ getAddressState address' 858 | lift $ lift $ lift $ 859 | putAddressState address' newAddressState{addressStateCodeHash=hash codeBytes'} 860 | 861 | 862 | 863 | --bool Executive::call(Address _receiveAddress, Address _codeAddress, Address _senderAddress, u256 _value, u256 _gasPrice, bytesConstRef _data, u256 _gas, Address _originAddress) 864 | 865 | call::Block->Int->Address->Address->Address->Word256->Word256->B.ByteString->Integer->Address->ContextM (Either VMException B.ByteString, VMState) 866 | call b callDepth' receiveAddress (Address codeAddress) sender value' gasPrice' theData availableGas origin = do 867 | 868 | addressState <- lift $ getAddressState $ Address codeAddress 869 | code <- lift $ Code <$> fromMaybe B.empty <$> getCode (addressStateCodeHash addressState) 870 | 871 | let env = 872 | Environment{ 873 | envGasPrice=fromIntegral gasPrice', 874 | envBlock=b, 875 | envOwner = receiveAddress, 876 | envOrigin = origin, 877 | envInputData = theData, 878 | envSender = sender, 879 | envValue = fromIntegral value', 880 | envCode = code, 881 | envJumpDests = getValidJUMPDESTs code 882 | } 883 | 884 | 885 | success <- pay "call value transfer" sender receiveAddress (fromIntegral value') 886 | 887 | ret <- 888 | runVMM callDepth' env (fromIntegral availableGas) $ 889 | if codeAddress > 0 && codeAddress < 5 890 | then callPrecompiledContract codeAddress theData 891 | else call' 892 | 893 | case ret of 894 | (Left _, _) -> do 895 | --if there was an error, addressStates were reverted, so the receiveAddress still should 896 | --have the value, and I can revert without checking for success. 897 | _ <- pay "revert value transfer" receiveAddress sender (fromIntegral value') 898 | return ret 899 | _ -> return ret 900 | 901 | 902 | 903 | --bool Executive::call(Address _receiveAddress, Address _codeAddress, Address _senderAddress, u256 _value, u256 _gasPrice, bytesConstRef _data, u256 _gas, Address _originAddress) 904 | 905 | call'::VMM B.ByteString 906 | --call' callDepth' address codeAddress sender value' gasPrice' theData availableGas origin = do 907 | call' = do 908 | 909 | --whenM isDebugEnabled $ liftIO $ putStrLn $ "availableGas: " ++ show availableGas 910 | 911 | runCodeFromStart 912 | 913 | vmState <- lift get 914 | 915 | whenM (lift $ lift isDebugEnabled) $ liftIO $ do 916 | let result = fromMaybe B.empty $ returnVal vmState 917 | --putStrLn $ "Result: " ++ format result 918 | putStrLn $ "Gas remaining: " ++ show (vmGasRemaining vmState) ++ ", needed: " ++ show (5*toInteger (B.length result)) 919 | --putStrLn $ show (pretty address) ++ ": " ++ format result 920 | 921 | return (fromMaybe B.empty $ returnVal vmState) 922 | 923 | 924 | 925 | 926 | 927 | create_debugWrapper::Block->Address->Word256->B.ByteString->VMM (Maybe Address) 928 | create_debugWrapper block owner value initCodeBytes = do 929 | 930 | addressState <- lift $ lift $ lift $ getAddressState owner 931 | 932 | if fromIntegral value > addressStateBalance addressState 933 | then return Nothing 934 | else do 935 | newAddress <- lift $ lift $ getNewAddress owner 936 | 937 | 938 | let initCode = Code initCodeBytes 939 | 940 | origin <- getEnvVar envOrigin 941 | gasPrice <- getEnvVar envGasPrice 942 | 943 | gasRemaining <- getGasRemaining 944 | 945 | currentCallDepth <- getCallDepth 946 | 947 | (result, finalVMState) <- 948 | lift $ lift $ 949 | create block (currentCallDepth+1) owner origin (toInteger value) gasPrice gasRemaining newAddress initCode 950 | 951 | setGasRemaining $ vmGasRemaining finalVMState 952 | 953 | case result of 954 | Left e -> do 955 | whenM (lift $ lift isDebugEnabled) $ liftIO $ putStrLn $ CL.red $ show e 956 | return Nothing 957 | Right _ -> do 958 | 959 | forM_ (reverse $ logs finalVMState) addLog 960 | forM_ (reverse $ suicideList finalVMState) addSuicideList 961 | 962 | return $ Just newAddress 963 | 964 | 965 | 966 | 967 | 968 | nestedRun_debugWrapper::Integer->Address->Address->Address->Word256->B.ByteString->VMM (Int, Maybe B.ByteString) 969 | nestedRun_debugWrapper gas receiveAddress (Address address') sender value inputData = do 970 | 971 | -- theAddressExists <- lift $ lift $ lift $ addressStateExists (Address address') 972 | 973 | currentCallDepth <- getCallDepth 974 | 975 | env <- lift $ fmap environment $ get 976 | 977 | (result, finalVMState) <- 978 | lift $ lift $ 979 | call (envBlock env) (currentCallDepth+1) receiveAddress (Address address') sender value (fromIntegral $ envGasPrice env) inputData gas (envOrigin env) 980 | 981 | case result of 982 | Right retVal -> do 983 | forM_ (reverse $ logs finalVMState) addLog 984 | forM_ (reverse $ suicideList finalVMState) addSuicideList 985 | whenM (lift $ lift isDebugEnabled) $ 986 | liftIO $ putStrLn $ "Refunding: " ++ show (vmGasRemaining finalVMState) 987 | useGas (- vmGasRemaining finalVMState) 988 | addToRefund (refund finalVMState) 989 | return (1, Just retVal) 990 | Left e -> do 991 | whenM (lift $ lift isDebugEnabled) $ liftIO $ putStrLn $ CL.red $ show e 992 | return (0, Nothing) 993 | --------------------------------------------------------------------------------