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