{-# 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)