diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,92 @@ +# blockchain + +Generic blockchain implementation in Haskell. Heavily inspired by Bitcoin blockchain, but does not fully comply to the Bitcoin blockchain spec. Should be suitable for creating arbitrary Bitcoin-like blockchains with in various configurations. + +Build + +``` +$ stack build +``` + +Test + +``` +$ stack test -- run unit tests +$ ./scripts/test_mining -- run test mining network +$ ./scripts/test_stats -- print blockchain stats +``` + +#### notable differences from Bitcoin blockchain + +* Merkle root computed with extra leaves at end of tree (compared to extra leaves duplicated in bitcoin) +* Entities serialized as json +* Blockchain config is encoded in blockchain +* Blocks include a dedicated coinbase transaction field to simplify special case handling +* Block headers include an additional field for coinbase transaction hash +* A "transaction in" must declare its previous transaction hash as either a coinbase transaction or a normal transaction + +## design goals + +* Enforce invariants in types whenever possible (non-empty transactions, genesis block, coinbase transactions, etc.) +* Make it simple to create blockchains with arbitrary configurations +* Make construction of unverified blockchains easy, but provide assurance any validated blockchain instance conforms to expected rules +* Blocks & transactions are never presumed to be a valid part of a blockchain unless present in a validated blockchain +* Adding new blocks to a validated blockchain can assume validity prior parts of the blockchain +* Inspecting unspent transaction outputs of a validated blockchain can assume validity of all transactions +* Blockchain should be readily serializable + +## docs + +A blockchain is a config and a tree of blocks with each node having a potentially infinite set of branches. A `Blockchain` also includes a tag to note whether is has been verified to meet all the expected conditions -- `Blockchain Validated` or `Blockchain Unvalidated`. + +```hs +data Blockchain a = Blockchain + { _config :: BlockchainConfig + , _node :: BlockchainNode + } + +data BlockchainNode = BlockchainNode + { nodeBlock :: Block + , nodeNodes :: [BlockchainNode] + } +``` + +Blockchain construction revolves around three basic functions. Note: the `BlockchainNode` constructor is exported, while the top level `Blockchain` constructor is not. + +```hs +-- build an unvalidated blockchain from a config and node +construct :: BlockchainConfig -> BlockchainNode -> Blockchain Unvalidated + +-- validate the blockchain +validate :: Blockchain Unvalidated -> Either ValidationException (Blockchain Validated) + +-- add a block +addBlock :: Block -> Blockchain Validated -> Either BlockException (Blockchain Validated) +``` + +Finally, blocks are created by mining. This is a process of finding a `Block` with a certain shape so that it satisfies the expected difficulty, as defined in the blockchain config. Blocks are mined with the coinbase reward going to the provided public key. Note: this function may take a long time to finish executing. Most realistic use cases should run this in a separate thread that can be canceled. + +```hs +mineBlock :: PublicKey -> [Transaction] -> Blockchain Validated -> IO (Either MineBlockException Block) +``` + +## todo + +* Test attempts to double spend address funds -- particularly within the same transaction +* Implement `createTransaction` (currently only `createSimpleTransaction`) +* Function that validates transactions -- outside of create transaction logic +* Implement max transaction count per block +* Cache block header hash on block (and maybe transactions) for more efficient operations + * Maybe cache on the blockchain itself, and `validate` computes/checks hashes? + +## references + +* http://www.stephendiehl.com/posts/smart_contracts.html +* http://kadena.io/docs/Kadena-PactWhitepaper.pdf +* http://davidederosa.com/basic-blockchain-programming/ +* https://en.bitcoin.it/wiki/Transaction +* https://en.bitcoin.it/wiki/Block +* https://en.bitcoin.it/wiki/Block_hashing_algorithm +* https://en.bitcoin.it/wiki/Hashcash +* https://en.bitcoin.it/wiki/Genesis_block +* https://en.bitcoin.it/wiki/Protocol_rules#.22tx.22_messages diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/blockchain.cabal b/blockchain.cabal new file mode 100644 --- /dev/null +++ b/blockchain.cabal @@ -0,0 +1,104 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: blockchain +version: 0.0.0.1 +synopsis: Generic blockchain implementation. +description: Please see README.md +category: Blockchain +homepage: https://github.com/TGOlson/blockchain +author: Tyler Olson +maintainer: tydotg@gmail.com +copyright: 2017 Tyler Olson +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +library + hs-source-dirs: + lib + default-extensions: BangPatterns DefaultSignatures DeriveGeneric FlexibleInstances GeneralizedNewtypeDeriving LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables + ghc-options: -Wall + build-depends: + aeson + , base >= 4.7 && < 5 + , byteable + , bytestring + , cryptonite + , either + , errors + , hashable + , memory + , mtl + , text + , time + , transformers + , unordered-containers + exposed-modules: + Data.Blockchain.Core.Blockchain + Data.Blockchain.Core.Builder.Transaction + Data.Blockchain.Core.Crypto + Data.Blockchain.Core.Crypto.ECDSA + Data.Blockchain.Core.Crypto.Hash + Data.Blockchain.Core.Crypto.HashTree + Data.Blockchain.Core.Types + Data.Blockchain.Core.Types.Block + Data.Blockchain.Core.Types.BlockchainConfig + Data.Blockchain.Core.Types.Difficulty + Data.Blockchain.Core.Types.Transaction + Data.Blockchain.Core.Util.Hex + Data.Blockchain.Mining.Block + Data.Blockchain.Mining.Blockchain + other-modules: + Paths_blockchain + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test + default-extensions: BangPatterns DefaultSignatures DeriveGeneric FlexibleInstances GeneralizedNewtypeDeriving LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables + ghc-options: -Wall + build-depends: + aeson + , base >= 4.7 && < 5 + , byteable + , bytestring + , cryptonite + , either + , errors + , hashable + , memory + , mtl + , text + , time + , transformers + , unordered-containers + , async + , blockchain + , deepseq + , hspec + , QuickCheck + other-modules: + ArbitraryInstances + Data.Blockchain.Core.BlockchainSpec + Data.Blockchain.Core.Builder.TransactionSpec + Data.Blockchain.Core.Crypto.ECDSASpec + Data.Blockchain.Core.Crypto.HashSpec + Data.Blockchain.Core.Crypto.HashTreeSpec + Data.Blockchain.Core.Types.BlockchainConfigSpec + Data.Blockchain.Core.Types.DifficultySpec + Data.Blockchain.Core.Types.TransactionSpec + Data.Blockchain.Core.Util.HexSpec + Data.Blockchain.Mining.BlockSpec + Integration.Mining + Integration.Stats + TestData + TestUtil + default-language: Haskell2010 diff --git a/lib/Data/Blockchain/Core/Blockchain.hs b/lib/Data/Blockchain/Core/Blockchain.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Blockchain.hs @@ -0,0 +1,323 @@ +module Data.Blockchain.Core.Blockchain + -- Types + ( Validated + , Unvalidated + , Blockchain + , blockchainConfig + , blockchainNode + , BlockchainNode(..) + , ValidationException(..) + , BlockException(..) + -- Construction + , construct + , validate + , addBlock + -- Validation + , validateTransaction + , validateTransactions + -- Chain inspection + , blockHeaderHashDifficulty + , addressValues + , unspentTransactionOutputs + , longestChain + , flatten + ) where + +import Control.Monad (unless) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Char as Char +import qualified Data.Either as Either +import qualified Data.Either.Combinators as Either +import qualified Data.Foldable as Foldable +import qualified Data.HashMap.Strict as H +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid ((<>)) +import qualified Data.Ord as Ord +import qualified Data.Word as Word +import qualified GHC.Generics as Generic + +import qualified Data.Blockchain.Core.Crypto as Crypto +import Data.Blockchain.Core.Types +import qualified Data.Blockchain.Core.Util.Hex as Hex + +-- Types ---------------------------------------------------------------------------------------------------- + +data Validated +data Unvalidated + +data Blockchain a = Blockchain + { _config :: BlockchainConfig + , _node :: BlockchainNode + } + deriving (Generic.Generic, Eq, Show) + +blockchainConfig :: Blockchain a -> BlockchainConfig +blockchainConfig = _config + +blockchainNode :: Blockchain a -> BlockchainNode +blockchainNode = _node + +instance Aeson.FromJSON (Blockchain Unvalidated) where + parseJSON = Aeson.genericParseJSON (stripFieldPrefix "_") + +instance Aeson.ToJSON (Blockchain a) where + toEncoding = Aeson.genericToEncoding (stripFieldPrefix "_") + +data BlockchainNode = BlockchainNode + { nodeBlock :: Block + , nodeNodes :: [BlockchainNode] + } + deriving (Generic.Generic, Eq, Show) + +instance Aeson.FromJSON BlockchainNode where + parseJSON = Aeson.genericParseJSON (stripFieldPrefix "node") + +instance Aeson.ToJSON BlockchainNode where + toEncoding = Aeson.genericToEncoding (stripFieldPrefix "node") + +data ValidationException + = GenesisBlockHasTransactions + | GenesisBlockException BlockException + | BlockValidationException BlockException + deriving (Eq, Show) + +data BlockException + = BlockAlreadyExists + | NoParentFound + -- timestamps + | TimestampTooOld + | TimestampTooFarIntoFuture + -- difficulty + | InvalidDifficultyReference + | InvalidDifficulty + -- header refs + | InvalidCoinbaseTransactionHash + | InvalidTransactionHashTreeRoot + -- transactions + | InvalidCoinbaseTransactionValue + | InvalidTransactionValues + | TransactionOutRefNotFound + | InvalidTransactionSignature + deriving (Eq, Show) + + +-- Construction --------------------------------------------------------------------------------------------- + +construct :: BlockchainConfig -> BlockchainNode -> Blockchain Unvalidated +construct = Blockchain + + +validate :: Blockchain Unvalidated -> Either ValidationException (Blockchain Validated) +validate (Blockchain config (BlockchainNode genesisBlock nodes)) = do + let (Block header _coinbase txs) = genesisBlock + reward = initialMiningReward config + blockchainHead = Blockchain config (BlockchainNode genesisBlock mempty) + blocks = nodes >>= getBlocks + + verify (null txs) GenesisBlockHasTransactions + Either.mapLeft BlockValidationException $ validateBlockDifficulty header config mempty + Either.mapLeft BlockValidationException $ validateBlockTransactions genesisBlock mempty reward + Either.mapLeft BlockValidationException $ validateBlockHeaderReferences genesisBlock + Either.mapLeft BlockValidationException $ Foldable.foldlM (flip addBlock) blockchainHead blocks + where + getBlocks (BlockchainNode block ns) = block : (ns >>= getBlocks) + + +addBlock :: Block -> Blockchain Validated -> Either BlockException (Blockchain Validated) +addBlock newBlock (Blockchain config node) = Blockchain config <$> addBlockToNode mempty node + where + addBlockToNode :: [Block] -> BlockchainNode -> Either BlockException BlockchainNode + addBlockToNode priorChain (BlockchainNode block nodes) = + if isParentNode then do + let siblingBlocks = nodeBlock <$> nodes + newNode = BlockchainNode newBlock mempty + updatedNode = BlockchainNode block (newNode : nodes) + height = length previousBlocks + 1 + newBlockHeader = blockHeader newBlock + + verify (newBlock `notElem` siblingBlocks) BlockAlreadyExists + validateBlockCreationTime newBlockHeader (blockHeader block) + validateBlockDifficulty newBlockHeader config previousBlocks + validateBlockTransactions newBlock previousBlocks (targetReward config $ fromIntegral height) + validateBlockHeaderReferences newBlock + + return updatedNode + else + let eBlockchains = fmap (\bs -> Either.mapLeft (\e -> (e, bs)) (addBlockToNode previousBlocks bs)) nodes in + BlockchainNode block <$> reduceAddBlockResults eBlockchains + where + previousBlocks = priorChain <> pure block + isParentNode = Crypto.hash (blockHeader block) == prevBlockHeaderHash (blockHeader newBlock) + + reduceAddBlockResults :: [Either (BlockException, BlockchainNode) BlockchainNode] -> Either BlockException [BlockchainNode] + reduceAddBlockResults results = + case (rightResults, specificExceptions) of + ([x], []) -> Right (oldBlockChains <> pure x) + ([], []) -> Left NoParentFound + ([], [e]) -> Left e + (_, _) -> error "Impossible block insertion error" + where + (leftResults, rightResults) = Either.partitionEithers results + (allExceptions, oldBlockChains) = unzip leftResults + specificExceptions = filter (not . (==) NoParentFound) allExceptions + + +-- Exported Validators --------------------------------------------------------------------------------------- + +-- TODO: transaction-specific exceptions +validateTransaction :: Blockchain Validated -> Transaction -> Either BlockException () +validateTransaction chain = validateTransactions chain . pure + +validateTransactions :: Blockchain Validated -> [Transaction] -> Either BlockException () +validateTransactions chain = \case + [] -> return () -- slight optimization - prevents having to calculate unspent transaction outputs + xs -> let prevBlocks = NonEmpty.toList (longestChain chain) + unspentTransactions = unspentTransactionOutputsInternal prevBlocks + in sequence_ $ validateTransactionInternal unspentTransactions <$> xs + +-- Internal Validation --------------------------------------------------------------------------------------- + +-- block references expected difficulty +-- block header hashes to expected difficulty +validateBlockDifficulty :: BlockHeader -> BlockchainConfig -> [Block] -> Either BlockException () +validateBlockDifficulty header config blocks = do + verify (difficulty header == diff) InvalidDifficultyReference + verify (blockHeaderHashDifficulty (difficulty1Target config) header >= diff) InvalidDifficulty + where + diff = targetDifficulty config blocks + +-- Exported util +-- TODO: find better place for this function + +blockHeaderHashDifficulty :: Hex.Hex256 -> BlockHeader -> Difficulty +blockHeaderHashDifficulty diff1 header = fromIntegral $ diff1 `div` Crypto.hashToHex (Crypto.hash header) + + +-- block was not created before parent +-- TODO: The protocol rejects blocks with a timestamp earlier than the median of the timestamps from the previous 11 blocks +-- TODO: block created less than X hours, or N blocks intervals, into future +validateBlockCreationTime :: BlockHeader -> BlockHeader -> Either BlockException () +validateBlockCreationTime newBlockHeader parentBlockHeader = + verify (newBlockTimestamp > time parentBlockHeader) TimestampTooOld + -- verify (newBlockTimestamp < now) TimestampTooFarIntoFuture + where + newBlockTimestamp = time newBlockHeader + +validateBlockHeaderReferences :: Block -> Either BlockException () +validateBlockHeaderReferences (Block header coinbase txs) = do + verify (Crypto.hash coinbase == coinbaseTransactionHash header) InvalidCoinbaseTransactionHash + verify (Crypto.hashTreeRoot txs == transactionHashTreeRoot header) InvalidTransactionHashTreeRoot + + +-- TODO: transactions should be able to reference transactions within the same block +-- this means we should try to apply a transaction, if it fails, try to apply next transaction +-- recurse until stable +-- TODO: until this is implemented it will be possible to "double spend" in the same block... : ( +validateBlockTransactions :: Block -> [Block] -> Word.Word -> Either BlockException () +validateBlockTransactions (Block _header coinbaseTx txs) prevBlocks reward = do + -- ensure coinbase transaction is of correct value + -- TODO: coinbase can be reward + fees + verify (txOutValue (coinbaseTransactionOut coinbaseTx) == reward) InvalidCoinbaseTransactionValue + + sequence_ (validateTransactionInternal unspentTransactions <$> txs) + where + unspentTransactions = unspentTransactionOutputsInternal prevBlocks + +txOutValue :: NonEmpty.NonEmpty TransactionOut -> Word.Word +txOutValue = sum . fmap value + +validateTransactionInternal :: H.HashMap TransactionOutRef TransactionOut -> Transaction -> Either BlockException () +validateTransactionInternal unspentTransactions (Transaction txIn txOut) = do + prevTxOut <- sequence $ flip fmap txIn $ \(TransactionIn ref sig) -> do + tx <- maybeToEither TransactionOutRefNotFound (H.lookup ref unspentTransactions) + verify (verifyTransactionSignature sig tx) InvalidTransactionSignature + return tx + + verify (txOutValue prevTxOut >= txOutValue txOut) InvalidTransactionValues + + +-- Transaction State ----------------------------------------------------------------------------------------- + +addressValues :: Blockchain Validated -> H.HashMap Crypto.PublicKey Word.Word +addressValues blockchain = H.fromListWith (+) (toPair <$> unspentTxOuts) + where + toPair (TransactionOut value pubKey) = (pubKey, value) + unspentTxOuts = H.elems $ unspentTransactionOutputsInternal (NonEmpty.toList $ longestChain blockchain) + +unspentTransactionOutputs :: Blockchain Validated -> H.HashMap Crypto.PublicKey [(TransactionOutRef, TransactionOut)] +unspentTransactionOutputs blockchain = H.fromListWith (<>) (toPair <$> unspentTxOuts) + where + toPair (txRef, txOut) = (signaturePubKey txOut, pure (txRef, txOut)) + unspentTxOuts = H.toList $ unspentTransactionOutputsInternal (NonEmpty.toList $ longestChain blockchain) + +-- Note: this is required to be an internal method +-- As we assume the list of blocks is a verified sub-chain. +-- TODO: similar issue to "verify transactions", does not recursively apply txouts within a transaction +unspentTransactionOutputsInternal :: [Block] -> H.HashMap TransactionOutRef TransactionOut +unspentTransactionOutputsInternal = + foldr (\(Block _ coinbase txs) -> addTransactions txs . addCoinbaseTransaction coinbase) mempty + where + addCoinbaseTransaction :: CoinbaseTransaction -> H.HashMap TransactionOutRef TransactionOut -> H.HashMap TransactionOutRef TransactionOut + addCoinbaseTransaction coinbase = H.unionWith onDuplicate coinbaseTxOutRefMap + where + -- TODO: revisit what it means to have duplicate coinbase transaction refs... probably ok? + onDuplicate (TransactionOut v1 key) (TransactionOut v2 _) = TransactionOut (v1 + v2) key + coinbaseTxOutRefMap = makeTxOutRefMap (Left $ Crypto.hash coinbase) (coinbaseTransactionOut coinbase) + + addTransactions :: [Transaction] -> H.HashMap TransactionOutRef TransactionOut -> H.HashMap TransactionOutRef TransactionOut + addTransactions txs hmap = foldr addTransaction hmap txs + + addTransaction :: Transaction -> H.HashMap TransactionOutRef TransactionOut -> H.HashMap TransactionOutRef TransactionOut + addTransaction tx@(Transaction txIns txOuts) = H.unionWith onDuplicateTxOutRef txOutRefMap . enforceDeleteAll txOutRefsFromTxIns + where + txOutRefsFromTxIns = NonEmpty.toList (transactionOutRef <$> txIns) + txOutRefMap = makeTxOutRefMap (Right $ Crypto.hash tx) txOuts + -- Map utils, enforcing expected invariants + enforceDelete k = H.alter (maybe (onNotFoundTxOutRef k) (const Nothing)) k + enforceDeleteAll ks hmap = foldr enforceDelete hmap ks + + makeTxOutRefMap :: Either (Crypto.Hash CoinbaseTransaction) (Crypto.Hash Transaction) -> NonEmpty.NonEmpty TransactionOut -> H.HashMap TransactionOutRef TransactionOut + makeTxOutRefMap eHash txOuts = H.fromList txOutRefPair + where + txOutIndexed = zip (NonEmpty.toList txOuts) [0..] + txOutRefPair = (\(txOut, i) -> (TransactionOutRef eHash i, txOut)) <$> txOutIndexed + + onDuplicateTxOutRef txOutRef = error ("Unexpected error when computing transaction map - duplicate transaction: " <> show txOutRef) + onNotFoundTxOutRef txOutRef = error ("Unexpected error when computing transaction map - transaction not found: " <> show txOutRef) + + +-- Chain inspection ----------------------------------------------------------------------------------------- + +longestChain :: Blockchain Validated -> NonEmpty.NonEmpty Block +longestChain = List.maximumBy lengthOrDifficulty . flatten + where + lengthOrDifficulty chain1 chain2 = + case Ord.comparing length chain1 chain2 of + EQ -> Ord.comparing chainDifficulty chain1 chain2 + x -> x + chainDifficulty = sum . fmap (difficulty . blockHeader) + +flatten :: Blockchain Validated -> NonEmpty.NonEmpty (NonEmpty.NonEmpty Block) +flatten = flattenInternal . blockchainNode + where + flattenInternal :: BlockchainNode -> NonEmpty.NonEmpty (NonEmpty.NonEmpty Block) + flattenInternal = \case + BlockchainNode block [] -> pure $ pure block + BlockchainNode block bcs -> NonEmpty.cons block <$> (NonEmpty.fromList bcs >>= flattenInternal) + +-- Utils ---------------------------------------------------------------------------------------------------- + +verify :: Bool -> a -> Either a () +verify cond = unless cond . Left + +maybeToEither :: a -> Maybe b -> Either a b +maybeToEither e = maybe (Left e) Right + +stripFieldPrefix :: String -> Aeson.Options +stripFieldPrefix str = Aeson.defaultOptions { Aeson.fieldLabelModifier = stripPrefix } + where + stripPrefix x = maybe x lowercase (List.stripPrefix str x) + lowercase = \case [] -> [] + (x:xs) -> Char.toLower x : xs diff --git a/lib/Data/Blockchain/Core/Builder/Transaction.hs b/lib/Data/Blockchain/Core/Builder/Transaction.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Builder/Transaction.hs @@ -0,0 +1,58 @@ +module Data.Blockchain.Core.Builder.Transaction + ( CreateTransactionException(..) + -- , createTransaction + , createSimpleTransaction + ) where + +import Control.Monad (unless, when) +import Control.Monad.Trans.Class (lift) + +import qualified Control.Error.Util as Error +import qualified Control.Monad.Except as Except +import qualified Data.HashMap.Strict as H +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Word as Word + +import qualified Data.Blockchain.Core.Blockchain as Blockchain +import qualified Data.Blockchain.Core.Crypto as Crypto +import qualified Data.Blockchain.Core.Types as Blockchain + +data CreateTransactionException + = SourceAddressEmpty + | SourceAddressInsufficientFunds + | InvalidPrivateKey + deriving (Eq, Show) + +-- TODO +-- createTransaction +-- :: [Crypto.KeyPair] -> [(Crypto.PublicKey, Int)] -> Int -> Blockchain.Blockchain Blockchain.Validated +-- -> Either CreateTransactionException Blockchain.Transaction +-- createTransaction _srcs _targets _fee _blockchain = undefined + +createSimpleTransaction + :: Crypto.KeyPair -> Crypto.PublicKey + -> Word.Word -> Word.Word -> Blockchain.Blockchain Blockchain.Validated + -> IO (Either CreateTransactionException Blockchain.Transaction) +createSimpleTransaction (Crypto.KeyPair srcPubKey srcPrivKey) targetPubKey value fee blockchain = Except.runExceptT $ do + let unspentTransactionOutputs = Blockchain.unspentTransactionOutputs blockchain + + txOutPairs <- Error.failWith SourceAddressEmpty $ H.lookup srcPubKey unspentTransactionOutputs + + let txOuts = snd <$> txOutPairs + totalValue = sum $ Blockchain.value <$> txOuts + + when (totalValue < (value + fee)) $ Except.throwError SourceAddressInsufficientFunds + + txIns <- sequence $ flip fmap txOutPairs $ \(txOutRef, txOut) -> do + sig <- lift $ Blockchain.signTransaction srcPrivKey txOut + unless (Blockchain.verifyTransactionSignature sig txOut) $ Except.throwError InvalidPrivateKey + + return (Blockchain.TransactionIn txOutRef sig) + + let refund = totalValue - (value + fee) + txOut = Blockchain.TransactionOut value targetPubKey + maybeRefundTxOut = if refund > 0 then Just (Blockchain.TransactionOut refund srcPubKey) + else Nothing + txOuts' = maybe (pure txOut) (: pure txOut) maybeRefundTxOut + + return $ Blockchain.Transaction (NonEmpty.fromList txIns) (NonEmpty.fromList txOuts') diff --git a/lib/Data/Blockchain/Core/Crypto.hs b/lib/Data/Blockchain/Core/Crypto.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Crypto.hs @@ -0,0 +1,7 @@ +module Data.Blockchain.Core.Crypto + ( module X + ) where + +import Data.Blockchain.Core.Crypto.ECDSA as X +import Data.Blockchain.Core.Crypto.Hash as X +import Data.Blockchain.Core.Crypto.HashTree as X diff --git a/lib/Data/Blockchain/Core/Crypto/ECDSA.hs b/lib/Data/Blockchain/Core/Crypto/ECDSA.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Crypto/ECDSA.hs @@ -0,0 +1,131 @@ +module Data.Blockchain.Core.Crypto.ECDSA + ( KeyPair(..) + , Signature(..) + , PublicKey(..) + , PrivateKey(..) + , sign + , verify + , generate + ) where + +import qualified Crypto.Hash as Crypto +import qualified Crypto.PubKey.ECC.ECDSA as Crypto +import qualified Crypto.PubKey.ECC.Generate as Crypto +import qualified Crypto.PubKey.ECC.Types as Crypto +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.Hashable as H +import Data.Monoid ((<>)) +import qualified Data.Text as Text + +import Data.Blockchain.Core.Util.Hex + +-- Types ----------------------------------------------------------------------------------------------------- + +data KeyPair = KeyPair + { publicKey :: PublicKey + , privateKey :: PrivateKey + } + +-- Signature + +newtype Signature = Signature { unSignature :: Crypto.Signature } + deriving (Eq) + +instance Show Signature where + show (Signature (Crypto.Signature r s)) = show (hex256FromInteger r) <> show (hex256FromInteger s) + +instance Aeson.ToJSON Signature where + toJSON = Aeson.toJSON . show + +instance Aeson.FromJSON Signature where + parseJSON = Aeson.withText "Signature" $ \txt -> do + (rHex, sHex) <- parseHex256Tuple txt + + let sig = Crypto.Signature (toInteger rHex) (toInteger sHex) + + return (Signature sig) + +-- PublicKey + +newtype PublicKey = PublicKey { unPublicKey :: Crypto.PublicPoint } + deriving (Eq) + +instance H.Hashable PublicKey where + hashWithSalt _ = H.hash . show + +instance Show PublicKey where + show = \case PublicKey Crypto.PointO -> show $ PublicKey (Crypto.Point 0 0) + PublicKey (Crypto.Point x y) -> show (hex256FromInteger x) <> show (hex256FromInteger y) + +instance Aeson.ToJSON PublicKey where + toJSON = Aeson.toJSON . show + +instance Aeson.FromJSON PublicKey where + parseJSON = Aeson.withText "PublicKey" $ \txt -> do + (xHex, yHex) <- parseHex256Tuple txt + + let point = Crypto.Point (toInteger xHex) (toInteger yHex) + + return (PublicKey point) + +-- PrivateKey + +newtype PrivateKey = PrivateKey { unPrivateKey :: Crypto.PrivateNumber } + deriving (Eq) + +instance Show PrivateKey where + show = show . hex256FromInteger . unPrivateKey + +instance Aeson.ToJSON PrivateKey where + toJSON = Aeson.toJSON . show + +instance Aeson.FromJSON PrivateKey where + parseJSON = Aeson.withText "PrivateKey" $ fmap (PrivateKey . toInteger) . parseHex256 + +-- Core functions -------------------------------------------------------------------------------------------- + +-- Constants + +hashType :: Crypto.SHA256 +hashType = Crypto.SHA256 + +curve :: Crypto.Curve +curve = Crypto.getCurveByName Crypto.SEC_p256k1 + +sign :: PrivateKey -> BS.ByteString -> IO Signature +sign (PrivateKey number) = fmap Signature . Crypto.sign privKey hashType + where + privKey = Crypto.PrivateKey curve number + +verify :: PublicKey -> Signature -> BS.ByteString -> Bool +verify (PublicKey point) (Signature sig) = Crypto.verify hashType pubKey sig + where + pubKey = Crypto.PublicKey curve point + +generate :: IO KeyPair +generate = do + (pub, priv) <- Crypto.generate curve + + let publicPoint = Crypto.public_q pub + privateNumber = Crypto.private_d priv + + return $ KeyPair (PublicKey publicPoint) (PrivateKey privateNumber) + +-- Util ------------------------------------------------------------------------------------------------------ + +parseHex256 :: Monad m => Text.Text -> m Hex256 +parseHex256 = maybe (fail "Invalid hex 256 string") return . hex256 . Text.unpack + +parseHex256Tuple :: Monad m => Text.Text -> m (Hex256, Hex256) +parseHex256Tuple txt = do + let (xStr, yStr) = Text.splitAt 64 txt + + x <- parseHex256 xStr + y <- parseHex256 yStr + + return (x, y) + +-- unsafe, but used internally on integers we know will always be positive +hex256FromInteger :: Integer -> Hex256 +hex256FromInteger = fromInteger diff --git a/lib/Data/Blockchain/Core/Crypto/Hash.hs b/lib/Data/Blockchain/Core/Crypto/Hash.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Crypto/Hash.hs @@ -0,0 +1,65 @@ +module Data.Blockchain.Core.Crypto.Hash + ( Hash + , ToHash(..) + , hashToHex + , fromByteString + , unsafeFromByteString + ) where + +import qualified Crypto.Hash as Crypto +import qualified Data.Aeson as Aeson +import qualified Data.ByteArray.Encoding as Byte +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.Hashable as H +import qualified Data.Maybe as Maybe +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import qualified Data.Blockchain.Core.Util.Hex as Hex + +-- Types ----------------------------------------------------------------------------------------------------- + +data Hash a = Hash { unHash :: Crypto.Digest Crypto.SHA256 } + deriving (Eq, Ord) + +instance H.Hashable (Hash a) where + hashWithSalt _ = H.hash . show + +instance Show (Hash a) where + show = show . unHash + +instance Aeson.ToJSON (Hash a) where + toJSON = Aeson.String . Text.pack . show . unHash + +instance Aeson.FromJSON (Hash a) where + parseJSON = Aeson.withText "Hash" $ + maybe (fail "Invalid bytestring hash") return . fromByteString . Text.encodeUtf8 + +instance Monoid (Hash a) where + mempty = Hash $ Crypto.hash (mempty :: BS.ByteString) + mappend (Hash h1) (Hash h2) = Hash $ Crypto.hashFinalize $ Crypto.hashUpdates Crypto.hashInit [h1, h2] + +class ToHash a where + hash :: a -> Hash a + + default hash :: Aeson.ToJSON a => a -> Hash a + hash = Hash . Crypto.hash . Lazy.toStrict . Aeson.encode + +instance ToHash BS.ByteString where + hash = Hash . Crypto.hash + +-- Utils ----------------------------------------------------------------------------------------------------- + +-- Note: ignore all possible invariants that `Numeric.readHex` would normally need to check. +-- We are only converting string-ified hashes, which should always be valid hex strings. +hashToHex :: Hash a -> Hex.Hex256 +hashToHex = Maybe.fromMaybe (error "Unexpected hex conversion failure") . Hex.hex256 . show . unHash + +fromByteString :: BS.ByteString -> Maybe (Hash a) +fromByteString bs = case Byte.convertFromBase Byte.Base16 bs of + Left _ -> Nothing + Right bs' -> Hash <$> Crypto.digestFromByteString (bs' :: BS.ByteString) + +unsafeFromByteString :: BS.ByteString -> Hash a +unsafeFromByteString = Maybe.fromMaybe (error "Invalid hash string") . fromByteString diff --git a/lib/Data/Blockchain/Core/Crypto/HashTree.hs b/lib/Data/Blockchain/Core/Crypto/HashTree.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Crypto/HashTree.hs @@ -0,0 +1,30 @@ +module Data.Blockchain.Core.Crypto.HashTree + ( HashTreeRoot + , unHashTreeRoot + , hashTreeRoot + ) where + +import qualified Data.Aeson as Aeson + +import Data.Blockchain.Core.Crypto.Hash + +newtype HashTreeRoot a = HashTreeRoot { unHashTreeRoot :: Hash a } + deriving (Aeson.FromJSON, Aeson.ToJSON, Eq, Ord, Show) + +-- Note: hash tree constructed with extra leaves at end of tree. +-- This is NOT compatible with the Bitcoin implementation. +-- ┌───┴──┐ ┌────┴───┐ ┌─────┴─────┐ +-- ┌──┴──┐ │ ┌──┴──┐ │ ┌──┴──┐ ┌──┴──┐ +-- ┌─┴─┐ ┌─┴─┐ │ ┌─┴─┐ ┌─┴─┐ ┌─┴─┐ ┌─┴─┐ ┌─┴─┐ ┌─┴─┐ │ +-- (5-leaf) (6-leaf) (7-leaf) + +hashTreeRoot :: forall a. ToHash a => [a] -> HashTreeRoot a +hashTreeRoot = HashTreeRoot . buildHash + where + buildHash :: [a] -> Hash a + buildHash [] = mempty + buildHash [x] = hash x + buildHash xs = mappend (buildHash left) (buildHash right) + where + (left, right) = splitAt i xs + i = until (\x -> x * 2 >= length xs) (*2) 1 diff --git a/lib/Data/Blockchain/Core/Types.hs b/lib/Data/Blockchain/Core/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Types.hs @@ -0,0 +1,8 @@ +module Data.Blockchain.Core.Types + ( module X + ) where + +import Data.Blockchain.Core.Types.Block as X +import Data.Blockchain.Core.Types.BlockchainConfig as X +import Data.Blockchain.Core.Types.Difficulty as X +import Data.Blockchain.Core.Types.Transaction as X diff --git a/lib/Data/Blockchain/Core/Types/Block.hs b/lib/Data/Blockchain/Core/Types/Block.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Types/Block.hs @@ -0,0 +1,37 @@ +module Data.Blockchain.Core.Types.Block + ( Block(..) + , BlockHeader(..) + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.Time.Clock as Time +import qualified GHC.Generics as Generic + +import qualified Data.Blockchain.Core.Crypto as Crypto +import Data.Blockchain.Core.Types.Difficulty +import Data.Blockchain.Core.Types.Transaction + +data Block = Block + { blockHeader :: BlockHeader + , coinbaseTransaction :: CoinbaseTransaction + , transactions :: [Transaction] + } + deriving (Generic.Generic, Eq, Show) + +instance Aeson.FromJSON Block +instance Aeson.ToJSON Block + +data BlockHeader = BlockHeader + { version :: Int + , prevBlockHeaderHash :: Crypto.Hash BlockHeader + , coinbaseTransactionHash :: Crypto.Hash CoinbaseTransaction + , transactionHashTreeRoot :: Crypto.HashTreeRoot Transaction + , time :: Time.UTCTime + , difficulty :: Difficulty + , nonce :: Int + } + deriving (Generic.Generic, Eq, Show) + +instance Aeson.FromJSON BlockHeader +instance Aeson.ToJSON BlockHeader +instance Crypto.ToHash BlockHeader diff --git a/lib/Data/Blockchain/Core/Types/BlockchainConfig.hs b/lib/Data/Blockchain/Core/Types/BlockchainConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Types/BlockchainConfig.hs @@ -0,0 +1,83 @@ +module Data.Blockchain.Core.Types.BlockchainConfig + ( BlockchainConfig(..) + , defaultConfig + , targetReward + , targetDifficulty + ) where + +import Control.Monad (when) +import qualified Data.Aeson as Aeson +import qualified Data.Time.Clock as Time +import qualified Data.Word as Word +import qualified GHC.Generics as Generic + +import Data.Blockchain.Core.Types.Block +import Data.Blockchain.Core.Types.Difficulty +import qualified Data.Blockchain.Core.Util.Hex as Hex + +data BlockchainConfig = BlockchainConfig + { initialDifficulty :: Difficulty + -- Maximum hash - difficulties will be calculated using this value + , difficulty1Target :: Hex.Hex256 + , targetSecondsPerBlock :: Word.Word + , difficultyRecalculationHeight :: Word.Word + , initialMiningReward :: Word.Word + -- Defines num blocks when reward is halved -- `0` means reward never changes + , miningRewardHalvingHeight :: Word.Word + } + deriving (Generic.Generic, Eq, Show) + +instance Aeson.FromJSON BlockchainConfig +instance Aeson.ToJSON BlockchainConfig + +defaultConfig :: BlockchainConfig +defaultConfig = BlockchainConfig + { initialDifficulty = Difficulty 1 + , difficulty1Target = Hex.hex256LeadingZeros 4 + , targetSecondsPerBlock = 10 + , difficultyRecalculationHeight = 100 + , initialMiningReward = 100 + , miningRewardHalvingHeight = 500 + } + +targetReward :: BlockchainConfig -> Word.Word -> Word.Word +targetReward config height = either id id $ do + let initialReward = initialMiningReward config + halveHeight = miningRewardHalvingHeight config + + when (halveHeight == 0) $ Left initialReward + + let numHalves = height `div` halveHeight + + -- 2^64 is greater than maxBound :: Word + -- And any word halved 64 times will be zero + when (numHalves >= 64) $ Left 0 + + return $ initialReward `div` (2 ^ numHalves) + +-- TODO: array of blocks hold no assurances of expected invariants +-- for example block1 could be created more recently than blockN +-- should create a `SingleChain` wrapper +targetDifficulty :: BlockchainConfig -> [Block] -> Difficulty +targetDifficulty config [] = initialDifficulty config +targetDifficulty config _ | difficultyRecalculationHeight config == 0 = initialDifficulty config +targetDifficulty config _ | difficultyRecalculationHeight config == 1 = initialDifficulty config +targetDifficulty config _ | targetSecondsPerBlock config == 0 = initialDifficulty config +targetDifficulty config blocks = + case length blocks `mod` fromIntegral recalcHeight of + 0 -> + let recentBlocks = take (fromIntegral recalcHeight) (reverse blocks) + lastBlock = head recentBlocks + firstBlock = last recentBlocks + -- TODO: get rid of `abs`, move invariant into types + diffTime = abs $ Time.diffUTCTime (blockTime lastBlock) (blockTime firstBlock) + avgSolveTime = realToFrac diffTime / fromIntegral recalcHeight + solveRate = fromIntegral (targetSecondsPerBlock config) / avgSolveTime + lastDifficulty = difficulty (blockHeader lastBlock) + nextDifficulty = Difficulty $ round $ solveRate * toRational lastDifficulty + in nextDifficulty + + _ -> difficulty $ blockHeader $ last blocks + where + recalcHeight = difficultyRecalculationHeight config + blockTime = time . blockHeader diff --git a/lib/Data/Blockchain/Core/Types/Difficulty.hs b/lib/Data/Blockchain/Core/Types/Difficulty.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Types/Difficulty.hs @@ -0,0 +1,15 @@ +module Data.Blockchain.Core.Types.Difficulty + ( Difficulty(..) + ) where + +import qualified Data.Aeson as Aeson +import qualified Numeric.Natural as Natural + +import qualified Data.Blockchain.Core.Util.Hex as Hex + +newtype Difficulty = Difficulty { unDifficulty :: Natural.Natural } + deriving (Aeson.FromJSON, Aeson.ToJSON, Enum, Eq, Integral, Num, Real, Ord, Show) + +instance Bounded Difficulty where + minBound = 0 + maxBound = fromIntegral (maxBound :: Hex.Hex256) diff --git a/lib/Data/Blockchain/Core/Types/Transaction.hs b/lib/Data/Blockchain/Core/Types/Transaction.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Types/Transaction.hs @@ -0,0 +1,80 @@ +module Data.Blockchain.Core.Types.Transaction + ( Transaction(..) + , CoinbaseTransaction(..) + , TransactionIn(..) + , TransactionOutRef(..) + , TransactionOut(..) + , signTransaction + , verifyTransactionSignature + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.Hashable as H +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Word as Word +import qualified GHC.Generics as Generic + + +import qualified Data.Blockchain.Core.Crypto as Crypto + +data Transaction = Transaction + { transactionIn :: NonEmpty.NonEmpty TransactionIn + , transactionOut :: NonEmpty.NonEmpty TransactionOut + -- TODO: arbitrary bytes? + } + deriving (Generic.Generic, Eq, Show) + +instance Aeson.FromJSON Transaction +instance Aeson.ToJSON Transaction +instance Crypto.ToHash Transaction + +newtype CoinbaseTransaction = CoinbaseTransaction + { coinbaseTransactionOut :: NonEmpty.NonEmpty TransactionOut + } + deriving (Generic.Generic, Eq, Show) + +instance Aeson.FromJSON CoinbaseTransaction +instance Aeson.ToJSON CoinbaseTransaction +instance Crypto.ToHash CoinbaseTransaction + +data TransactionIn = TransactionIn + { transactionOutRef :: TransactionOutRef + -- Signature from prev transaction, using pubkey from prev transaction + , signature :: Crypto.Signature + } + deriving (Generic.Generic, Eq, Show) + +instance Aeson.ToJSON TransactionIn +instance Aeson.FromJSON TransactionIn +instance Crypto.ToHash TransactionIn + +-- Pointer to a specific TransactionOut +data TransactionOutRef = TransactionOutRef + { transactionHash :: Either (Crypto.Hash CoinbaseTransaction) (Crypto.Hash Transaction) + , transactionOutIndex :: Word.Word + } + deriving (Generic.Generic, Eq, Show) + +instance H.Hashable TransactionOutRef + +instance Aeson.FromJSON TransactionOutRef +instance Aeson.ToJSON TransactionOutRef + +data TransactionOut = TransactionOut + { value :: Word.Word + , signaturePubKey :: Crypto.PublicKey -- aka. address of where funds go + } + deriving (Generic.Generic, Eq, Show) + +instance Aeson.FromJSON TransactionOut +instance Aeson.ToJSON TransactionOut +instance Crypto.ToHash TransactionOut + +signTransaction :: Crypto.PrivateKey -> TransactionOut -> IO Crypto.Signature +signTransaction priv = Crypto.sign priv . Lazy.toStrict . Aeson.encode + +verifyTransactionSignature :: Crypto.Signature -> TransactionOut -> Bool +verifyTransactionSignature sig txOut = Crypto.verify pub sig $ Lazy.toStrict (Aeson.encode txOut) + where + pub = signaturePubKey txOut diff --git a/lib/Data/Blockchain/Core/Util/Hex.hs b/lib/Data/Blockchain/Core/Util/Hex.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Core/Util/Hex.hs @@ -0,0 +1,58 @@ +module Data.Blockchain.Core.Util.Hex + ( Hex256(..) + , hex256 + , hex256LeadingZeros + ) where + +import Control.Monad (unless) +import qualified Data.Aeson as Aeson +import qualified Data.Maybe as Maybe +import Data.Monoid ((<>)) +import qualified Data.Text as Text +import qualified Data.Word as Word +import qualified Numeric +import qualified Numeric.Natural as Natural + +-- Types ----------------------------------------------------------------------------------------------------- + +newtype Hex256 = Hex256 { unHex256 :: Natural.Natural } + deriving (Enum, Eq, Integral, Num, Real, Ord) + +instance Show Hex256 where + show = zeroPadded 64 . showHex . unHex256 + +instance Bounded Hex256 where + minBound = 0 + maxBound = Maybe.fromMaybe (error "Unexpected parse failure") $ readHexMaybe $ replicate 64 'f' + +instance Aeson.ToJSON Hex256 where + toJSON = Aeson.String . Text.pack . show + +instance Aeson.FromJSON Hex256 where + parseJSON = Aeson.withText "Hex256" parseHex256 + where + parseHex256 = maybe (fail "Invalid hex 256 string") return . hex256 . Text.unpack + +-- Construction helpers -------------------------------------------------------------------------------------- + +hex256LeadingZeros :: Word.Word -> Hex256 +hex256LeadingZeros n = maxBound `div` Hex256 (16 ^ n) + +hex256 :: String -> Maybe Hex256 +hex256 str = do + unless (length str == 64) Nothing + x <- readHexMaybe str + return (Hex256 x) + +readHexMaybe :: (Num a, Eq a) => String -> Maybe a +readHexMaybe str = case Numeric.readHex str of + [(x, "")] -> Just x + _ -> Nothing + +-- Utils ----------------------------------------------------------------------------------------------------- + +showHex :: (Show a, Integral a) => a -> String +showHex x = Numeric.showHex x mempty + +zeroPadded :: Int -> String -> String +zeroPadded x str = replicate (x - length str) '0' <> str diff --git a/lib/Data/Blockchain/Mining/Block.hs b/lib/Data/Blockchain/Mining/Block.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Mining/Block.hs @@ -0,0 +1,103 @@ +module Data.Blockchain.Mining.Block + ( MineBlockException(..) + , mineBlock + , mineEmptyBlock + , mineGenesisBlock + ) where + +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Time.Clock as Time +import qualified Data.Word as Word + +import qualified Data.Blockchain.Core.Blockchain as Blockchain +import qualified Data.Blockchain.Core.Crypto as Crypto +import qualified Data.Blockchain.Core.Types as Blockchain +import qualified Data.Blockchain.Core.Util.Hex as Hex + +data MineBlockException + = InvalidTransactionList + -- | ... + deriving (Eq, Show) + +mineBlock + :: Crypto.PublicKey -> [Blockchain.Transaction] -> Blockchain.Blockchain Blockchain.Validated + -> IO (Either MineBlockException Blockchain.Block) +mineBlock pubKey txs blockchain = + case Blockchain.validateTransactions blockchain txs of + Left _e -> return (Left InvalidTransactionList) + Right () -> Right <$> mineBlockInternal pubKey reward diff1 difficulty prevBlockHeaderHash txs + where + diff1 = Blockchain.difficulty1Target config + reward = Blockchain.targetReward config (fromIntegral $ length prevBlocks + 1) + config = Blockchain.blockchainConfig blockchain + difficulty = Blockchain.targetDifficulty config $ NonEmpty.toList prevBlocks -- TODO: next diff? + prevBlocks = Blockchain.longestChain blockchain + prevBlock = NonEmpty.last prevBlocks + prevBlockHeaderHash = Crypto.hash (Blockchain.blockHeader prevBlock) + + +mineEmptyBlock + :: Crypto.PublicKey -> Blockchain.Blockchain Blockchain.Validated + -> IO (Either MineBlockException Blockchain.Block) +mineEmptyBlock pubKey = mineBlock pubKey mempty + + +mineGenesisBlock :: Blockchain.BlockchainConfig -> IO Blockchain.Block +mineGenesisBlock config = do + -- Note: ignore private key, coinbase reward in genesis block cannot be spent + (Crypto.KeyPair pubKey _privKey) <- Crypto.generate + + mineBlockInternal pubKey reward diff1 difficulty prevBlockHeaderHash mempty + where + diff1 = Blockchain.difficulty1Target config + reward = Blockchain.initialMiningReward config + difficulty = Blockchain.initialDifficulty config + prevBlockHeaderHash = Crypto.unsafeFromByteString $ Char8.replicate 64 '0' + +-- TODO: accept multiple public keys +mineBlockInternal + :: Crypto.PublicKey -> Word.Word -> Hex.Hex256 -> Blockchain.Difficulty + -> Crypto.Hash Blockchain.BlockHeader -> [Blockchain.Transaction] + -> IO Blockchain.Block +mineBlockInternal pubKey reward diff1 difficulty prevBlockHeaderHash txs = do + header <- mineHeader + prevBlockHeaderHash + (Crypto.hash coinbaseTx) + (Crypto.hashTreeRoot txs) + diff1 + difficulty + + -- TODO: add up fees and include in coinbase reward + -- fee = address value - total tx value + return (Blockchain.Block header coinbaseTx txs) + where + coinbaseTx = Blockchain.CoinbaseTransaction $ pure (Blockchain.TransactionOut reward pubKey) + +-- TODO: could clean up param list by passing config down to this level +mineHeader + :: Crypto.Hash Blockchain.BlockHeader + -> Crypto.Hash Blockchain.CoinbaseTransaction + -> Crypto.HashTreeRoot Blockchain.Transaction + -> Hex.Hex256 + -> Blockchain.Difficulty + -> IO Blockchain.BlockHeader +mineHeader prevBlockHeaderHash coinbaseTransactionHash transactionHashTreeRoot diff1 difficulty = do + time <- Time.getCurrentTime + + let version = 0 + nonce = 0 + initialHeader = Blockchain.BlockHeader{..} + + mineHeaderInternal initialHeader + where + -- TODO: get current time in case of int overflow, + -- or in case current mining operation is getting close to oldest block time + mineHeaderInternal header = + if Blockchain.blockHeaderHashDifficulty diff1 header >= difficulty + then return header + else mineHeaderInternal (incNonce header) + + +incNonce :: Blockchain.BlockHeader -> Blockchain.BlockHeader +incNonce header = header { Blockchain.nonce = Blockchain.nonce header + 1 } diff --git a/lib/Data/Blockchain/Mining/Blockchain.hs b/lib/Data/Blockchain/Mining/Blockchain.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Blockchain/Mining/Blockchain.hs @@ -0,0 +1,21 @@ +module Data.Blockchain.Mining.Blockchain + ( createBlockchain + ) where + +import Data.Monoid ((<>)) + +import qualified Data.Blockchain.Core.Blockchain as Blockchain +import qualified Data.Blockchain.Core.Types as Blockchain +import Data.Blockchain.Mining.Block + + +createBlockchain :: Blockchain.BlockchainConfig -> IO (Blockchain.Blockchain Blockchain.Validated) +createBlockchain config = either throwValidationError id <$> do + genesisBlock <- mineGenesisBlock config + + let node = Blockchain.BlockchainNode genesisBlock mempty + chain = Blockchain.construct config node + + return (Blockchain.validate chain) + where + throwValidationError e = error $ "Unexpected error creating blockchain: " <> show e diff --git a/test/ArbitraryInstances.hs b/test/ArbitraryInstances.hs new file mode 100644 --- /dev/null +++ b/test/ArbitraryInstances.hs @@ -0,0 +1,117 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module ArbitraryInstances + ( MediumWord(..) + ) where + +import Test.QuickCheck + +import qualified Crypto.PubKey.ECC.ECDSA as Crypto +import qualified Crypto.PubKey.ECC.Types as Crypto +import qualified Data.ByteString.Char8 as BS +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid ((<>)) +import qualified Data.Time.Calendar as Time +import qualified Data.Time.Clock as Time +import qualified Data.Word as Word + +import Data.Blockchain.Core.Crypto +import Data.Blockchain.Core.Types +import Data.Blockchain.Core.Util.Hex + +-- Blockchain types + +instance Arbitrary BlockchainConfig where + arbitrary = BlockchainConfig + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Block where + arbitrary = Block + <$> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary BlockHeader where + arbitrary = BlockHeader + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> (hashTreeRoot <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary CoinbaseTransaction where + arbitrary = CoinbaseTransaction <$> arbitrary + +instance Arbitrary Transaction where + arbitrary = resize 5 $ Transaction <$> arbitrary <*> arbitrary + +instance Arbitrary TransactionIn where + arbitrary = resize 5 $ TransactionIn <$> arbitrary <*> arbitrary + +instance Arbitrary TransactionOut where + arbitrary = resize 5 $ TransactionOut <$> arbitrary <*> arbitrary + +instance Arbitrary TransactionOutRef where + arbitrary = TransactionOutRef <$> arbitrary <*> arbitrary + +instance Arbitrary Difficulty where + arbitrary = Difficulty <$> arbitrary + +-- Crypto Types + +instance Arbitrary (Hash a) where + arbitrary = unsafeFromByteString . BS.pack <$> vectorOf 64 hexChar + where + hexChar = elements $ ['0' .. '9'] <> ['a' .. 'f'] + +instance Arbitrary Signature where + arbitrary = Signature <$> arbitrarySig + where + arbitrarySig = Crypto.Signature + <$> arbitraryPositive + <*> arbitraryPositive + +instance Arbitrary PublicKey where + arbitrary = PublicKey <$> arbitraryPoint + where + arbitraryPoint = Crypto.Point + <$> arbitraryPositive + <*> arbitraryPositive + +instance Arbitrary PrivateKey where + arbitrary = PrivateKey <$> arbitraryPositive + +-- Other Types + +instance Arbitrary Hex256 where + arbitrary = Hex256 <$> arbitrary + +instance Arbitrary a => Arbitrary (NonEmpty.NonEmpty a) where + arbitrary = NonEmpty.fromList <$> listOf1 arbitrary + +instance Arbitrary BS.ByteString where + arbitrary = BS.pack <$> arbitrary + +instance Arbitrary Time.UTCTime where + arbitrary = Time.UTCTime <$> dayDen <*> dayTimeGen + where + -- The Modified Julian Day is a standard count of days, with zero being the day 1858-11-17. + dayDen = Time.ModifiedJulianDay <$> elements [0 .. 60000] + -- The time from midnight, 0 <= t < 86401s (because of leap-seconds) + dayTimeGen = Time.secondsToDiffTime <$> elements [0 .. 86400] + +newtype MediumWord = MediumWord Word.Word deriving (Eq, Show) +instance Arbitrary MediumWord where + arbitrary = elements $ MediumWord <$> [0..1000] + +-- Utils + +arbitraryPositive :: (Num a, Ord a, Arbitrary a) => Gen a +arbitraryPositive = getPositive <$> arbitrary diff --git a/test/Data/Blockchain/Core/BlockchainSpec.hs b/test/Data/Blockchain/Core/BlockchainSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Core/BlockchainSpec.hs @@ -0,0 +1,202 @@ +module Data.Blockchain.Core.BlockchainSpec (spec) where + +import TestUtil + +import qualified Control.Arrow as Arrow +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as H +import qualified Data.List.NonEmpty as NonEmpty + +import Data.Blockchain.Core.Blockchain +import Data.Blockchain.Core.Types + +spec :: Spec +spec = describe "Data.Blockchain.Core.Blockchain" $ do + it "should serialize and validate round-trip" $ once $ ioProperty $ do + chain <- blockchain3Block + + let unverifiedBlockchain = throwLeft $ Aeson.eitherDecode (Aeson.encode chain) + + return $ validate unverifiedBlockchain === Right chain + + describe "validate" $ do + it "should reject a chain with invalid difficulty reference in genesis block" $ once $ ioProperty $ do + chain <- singletonBlockchainUnvalidated + let config = (blockchainConfig chain) { initialDifficulty = minBound } + chain' = construct config (blockchainNode chain) + + return $ validate chain' === Left (BlockValidationException InvalidDifficultyReference) + + it "should reject a chain with invalid genesis block difficulty" $ once $ ioProperty $ do + chain <- singletonBlockchainUnvalidated + + let (BlockchainNode block nodes) = blockchainNode chain + blockHeader' = (blockHeader block) { nonce = 1 } + block' = block { blockHeader = blockHeader' } + chain' = construct (blockchainConfig chain) (BlockchainNode block' nodes) + + return $ validate chain' === Left (BlockValidationException InvalidDifficulty) + + it "should reject a chain with transactions in genesis block" $ once $ + \tx -> ioProperty $ do + chain <- singletonBlockchainUnvalidated + + let (BlockchainNode block nodes) = blockchainNode chain + block' = block { transactions = pure tx } + chain' = construct (blockchainConfig chain) (BlockchainNode block' nodes) + + return $ validate chain' === Left GenesisBlockHasTransactions + + it "should reject a chain with invalid coinbase reward in genesis block" $ once $ + \txOut -> ioProperty $ do + chain <- singletonBlockchainUnvalidated + + let (BlockchainNode block nodes) = blockchainNode chain + coinbase = CoinbaseTransaction $ pure $ txOut { value = 999 } + block' = block { coinbaseTransaction = coinbase } + chain' = construct (blockchainConfig chain) (BlockchainNode block' nodes) + + return $ validate chain' === Left (BlockValidationException InvalidCoinbaseTransactionValue) + + it "should reject a chain with invalid coinbase hash in genesis block header" $ once $ + \txOut -> ioProperty $ do + chain <- singletonBlockchainUnvalidated + + let (BlockchainNode block nodes) = blockchainNode chain + coinbase = CoinbaseTransaction $ pure $ txOut { value = 100 } + block' = block { coinbaseTransaction = coinbase } + chain' = construct (blockchainConfig chain) (BlockchainNode block' nodes) + + return $ validate chain' === Left (BlockValidationException InvalidCoinbaseTransactionHash) + + -- TODO: test if possible, hard to do with empty transaction rule & expected header hash + -- it "should reject a chain with invalid transaction hash in genesis block header" $ once $ + + describe "addBlock" $ do + -- Note: adding valid blocks is already tested by generating by loading test data + -- it "should add a valid block" ... + + it "should reject a duplicate block" $ once $ ioProperty $ do + blockchain <- blockchain1Block + block <- block1A + + return $ addBlock block blockchain === Left BlockAlreadyExists + + it "should reject a block without a parent" $ once $ ioProperty $ do + blockchain <- singletonBlockchain + block <- block2A + + return $ addBlock block blockchain === Left NoParentFound + + it "should reject a block with invalid genesis block difficulty" $ once $ ioProperty $ do + blockchain <- blockchain1Block + (Block header coinbase txs) <- block2A + + let header' = header { nonce = 1 } + block = Block header' coinbase txs + + return $ addBlock block blockchain === Left InvalidDifficulty + + it "should reject a block with invalid coinbase reward in block" $ once $ + \txOut -> ioProperty $ do + blockchain <- blockchain1Block + (Block header _coinbase txs) <- block2A + + let coinbase = CoinbaseTransaction $ pure $ txOut { value = 999 } + block = Block header coinbase txs + + return $ addBlock block blockchain === Left InvalidCoinbaseTransactionValue + + it "should reject a block with invalid coinbase hash in block header" $ once $ + \txOut -> ioProperty $ do + blockchain <- blockchain1Block + (Block header _coinbase txs) <- block2A + + let coinbase = CoinbaseTransaction $ pure $ txOut { value = 100 } + block = Block header coinbase txs + + return $ addBlock block blockchain === Left InvalidCoinbaseTransactionHash + + -- it "should reject a block with invalid transaction hash in block header" $ once $ + -- \tx -> ioProperty $ do + -- (blockchain, block) <- loadVerifiedTestBlockchainWithValidBlock + -- let block' = block { transactions = pure tx } + -- + -- return $ addBlock block' blockchain === Left InvalidTransactionHashTreeRoot + + it "should reject a block with an invalid transaction out ref" $ once $ + \txOutRef -> ioProperty $ do + blockchain <- blockchain1Block + (Block header coinbase txs) <- block2A + + let (Transaction txIn txOut) = head txs + txIn' = pure $ (NonEmpty.head txIn) { transactionOutRef = txOutRef } + block = Block header coinbase $ pure $ Transaction txIn' txOut + + return $ addBlock block blockchain === Left TransactionOutRefNotFound + + it "should reject a block with an invalid transaction signature" $ once $ + \sig -> ioProperty $ do + blockchain <- blockchain1Block + (Block header coinbase txs) <- block2A + + let (Transaction txIn txOut) = head txs + txIn' = pure $ (NonEmpty.head txIn) { signature = sig } + block = Block header coinbase $ pure $ Transaction txIn' txOut + + return $ addBlock block blockchain === Left InvalidTransactionSignature + + it "should reject a block with an invalid transaction value" $ once $ ioProperty $ do + blockchain <- blockchain1Block + (Block header coinbase txs) <- block2A + + let (Transaction txIn txOut) = head txs + txOut' = pure $ (NonEmpty.head txOut) { value = 999 } + block = Block header coinbase $ pure $ Transaction txIn txOut' + + return $ addBlock block blockchain === Left InvalidTransactionValues + + -- TODO: test + -- it "should reject a block with a duplicate transaction" $ once $ ioProperty $ do + + describe "addressValues" $ + it "should calculate unspent transaction outputs" $ once $ ioProperty $ do + blockchain <- blockchain3Block + + return $ showKeys (addressValues blockchain) === H.fromList + -- genesis coinbase, value can never be spent + [ ("8330da21047df515590bc752ac27210d3eb11bc1ec1b4dcb8f6c6b0b018fb5d44feb11798ca599b0c1549146508933833c4553d420504bef2c5f96dd42e143df", 100) + -- mined 1st and 2nd block, spent 90 of 1st block coinbase + , ("74bbe6d5f70f7d7e433b9b6d5d77a391492cc93161d9f108cef18d64959930cf1d55ef0844c0607f5568d1cd9233995154b5758915eb595e1dee472d13a18517", 110) + -- received 90 of 1st block coinbase + , ("c21609f09388037802a7c58e8135e264e8f4bac3354ee300ee73b887a7976a94614e77bcec828579562b9b3c0ac6f0de7323f3f5bcfdb3dfb190cfca1692d735", 90) + ] + + describe "flatten" $ + it "should flatten the blockchain" $ once $ ioProperty $ do + blockchain <- blockchain3Block + b0 <- genesisBlock + b1a <- block1A + b1b <- block1B + b2a <- block2A + + return $ flatten blockchain === NonEmpty.fromList + [ NonEmpty.fromList [b0, b1b] + , NonEmpty.fromList [b0, b1a, b2a] + ] + + describe "longestChain" $ + it "should find the longest chain" $ once $ ioProperty $ do + blockchain <- blockchain1Block + blockchain' <- blockchain2BlockFork + blockchain'' <- blockchain3Block + b0 <- genesisBlock + b1a <- block1A + b2a <- block2A + + return $ (longestChain blockchain == NonEmpty.fromList [b0, b1a]) && + (longestChain blockchain' == NonEmpty.fromList [b0, b1a]) && + (longestChain blockchain'' == NonEmpty.fromList [b0, b1a, b2a]) + +showKeys :: Show k => H.HashMap k v -> H.HashMap String v +showKeys = H.fromList . fmap (Arrow.first show) . H.toList diff --git a/test/Data/Blockchain/Core/Builder/TransactionSpec.hs b/test/Data/Blockchain/Core/Builder/TransactionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Core/Builder/TransactionSpec.hs @@ -0,0 +1,76 @@ +module Data.Blockchain.Core.Builder.TransactionSpec (spec) where + +import TestUtil + +import qualified Data.List.NonEmpty as NonEmpty + +import Data.Blockchain.Core.Blockchain +import Data.Blockchain.Core.Builder.Transaction +import Data.Blockchain.Core.Crypto +import Data.Blockchain.Core.Types + +blockchainItems :: IO (Blockchain Validated, KeyPair) +blockchainItems = do + blockchain <- blockchain1Block + block <- block1A + privateKey <- block1ACoinbasePrivateKey + + return (blockchain, KeyPair (coinbasePublicKey block) privateKey) + +coinbasePublicKey :: Block -> PublicKey +coinbasePublicKey = signaturePubKey . NonEmpty.head . coinbaseTransactionOut . coinbaseTransaction + +spec :: Spec +spec = describe "Data.Blockchain.Core.Builder.Transaction" $ + describe "createSimpleTransaction" $ do + propNumTests 5 "should create a valid transaction" $ + \(Small value) (Small fee) targetPublicKey -> value + fee < 100 ==> ioProperty $ do + (blockchain, keyPair) <- blockchainItems + + (Transaction txIn txOut) <- throwLeft <$> + createSimpleTransaction keyPair targetPublicKey value fee blockchain + + return $ + length txIn == 1 && + txOut == NonEmpty.fromList + [ TransactionOut (100 - value - fee) (publicKey keyPair) + , TransactionOut value targetPublicKey + ] + + propNumTests 5 "should not issue a refund if entire balance is spent" $ + \(Small value) targetPublicKey -> value < 100 ==> ioProperty $ do + (blockchain, keyPair) <- blockchainItems + + let fee = 100 - value + + (Transaction txIn txOut) <- throwLeft <$> + createSimpleTransaction keyPair targetPublicKey value fee blockchain + + return $ + length txIn == 1 && + txOut == NonEmpty.fromList [ TransactionOut value targetPublicKey ] + + propNumTests 5 "should reject transactions attempting to spend from empty address" $ + \(Small value) (Small fee) publicKey targetPublicKey -> value + fee < 100 ==> ioProperty $ do + (blockchain, KeyPair _ privKey) <- blockchainItems + + let keyPair = KeyPair publicKey privKey + + res <- createSimpleTransaction keyPair targetPublicKey value fee blockchain + return $ res === Left SourceAddressEmpty + + propNumTests 5 "should reject transactions attempting to spend more than is available in the address" $ + \(MediumWord value) (MediumWord fee) targetPublicKey -> value + fee > 100 ==> ioProperty $ do + (blockchain, keyPair) <- blockchainItems + + res <- createSimpleTransaction keyPair targetPublicKey value fee blockchain + return $ res === Left SourceAddressInsufficientFunds + + propNumTests 5 "should reject transactions with invalid private key" $ + \(Small value) (Small fee) privateKey targetPublicKey -> value + fee < 100 ==> ioProperty $ do + (blockchain, KeyPair pubKey _) <- blockchainItems + + let keyPair = KeyPair pubKey privateKey + + res <- createSimpleTransaction keyPair targetPublicKey value fee blockchain + return $ res === Left InvalidPrivateKey diff --git a/test/Data/Blockchain/Core/Crypto/ECDSASpec.hs b/test/Data/Blockchain/Core/Crypto/ECDSASpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Core/Crypto/ECDSASpec.hs @@ -0,0 +1,22 @@ +module Data.Blockchain.Core.Crypto.ECDSASpec (spec) where + +import TestUtil + +import Data.Blockchain.Core.Crypto.ECDSA + +spec :: Spec +spec = + describe "Data.Blockchain.Core.Crypto.ECDSA" $ do + safeJSONDeserializeSpec (Proxy :: Proxy PublicKey) + safeJSONDeserializeSpec (Proxy :: Proxy PrivateKey) + safeJSONDeserializeSpec (Proxy :: Proxy Signature) + + roundTripJSONSpec (Proxy :: Proxy PublicKey) + roundTripJSONSpec (Proxy :: Proxy PrivateKey) + roundTripJSONSpec (Proxy :: Proxy Signature) + + propNumTests 5 "should sign and verify correctly" $ + \bs -> ioProperty $ do + (KeyPair publicKey privateKey) <- generate + sig <- sign privateKey bs + return $ verify publicKey sig bs diff --git a/test/Data/Blockchain/Core/Crypto/HashSpec.hs b/test/Data/Blockchain/Core/Crypto/HashSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Core/Crypto/HashSpec.hs @@ -0,0 +1,23 @@ +module Data.Blockchain.Core.Crypto.HashSpec (spec) where + +import TestUtil + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as Char8 + +import Data.Blockchain.Core.Crypto.Hash + +spec :: Spec +spec = + describe "Data.Blockchain.Core.Crypto.Hash" $ do + prop "should hash to a hex" $ + \(bs :: BS.ByteString) -> hashToHex (hash bs) >= minBound + + prop "should round-trip json serialize" $ + \(bs :: BS.ByteString) -> let h = hash bs in + Aeson.decode (Aeson.encode h) == Just h + + prop "should round-trip bytestring serialize" $ + \(bs :: BS.ByteString) -> let h = hash bs in + fromByteString (Char8.pack $ show h) == Just h diff --git a/test/Data/Blockchain/Core/Crypto/HashTreeSpec.hs b/test/Data/Blockchain/Core/Crypto/HashTreeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Core/Crypto/HashTreeSpec.hs @@ -0,0 +1,33 @@ +module Data.Blockchain.Core.Crypto.HashTreeSpec (spec) where + +import TestUtil + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as Char8 +import Data.Monoid ((<>)) + +import Data.Blockchain.Core.Crypto + +testData :: [BS.ByteString] +testData = replicate (numBytes `div` blockSize) block <> [partialBlock] + where + blockSize = 64 + numBytes = (2 ^ (22 :: Int)) + 32 + block = Char8.replicate blockSize '\000' + partialBlock = Char8.replicate (numBytes `mod` blockSize) '\000' + +expectedRootHash :: Hash BS.ByteString +expectedRootHash = unsafeFromByteString "e9683665a90bd70aabd7705cba57c2be2a4e913a0ca1a14d765497112c178120" + +spec :: Spec +spec = + describe "Data.Blockchain.Core.Crypto.HashTree" $ do + it "should create a hash tree for a known hash" $ once $ + unHashTreeRoot (hashTreeRoot testData) === expectedRootHash + + prop "should hash a single item correctly" $ + \(bs :: BS.ByteString) -> + unHashTreeRoot (hashTreeRoot (pure bs)) === hash bs + + prop "should complete for any data" $ + \(bs :: [BS.ByteString]) -> let !_x = unHashTreeRoot (hashTreeRoot bs) in True diff --git a/test/Data/Blockchain/Core/Types/BlockchainConfigSpec.hs b/test/Data/Blockchain/Core/Types/BlockchainConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Core/Types/BlockchainConfigSpec.hs @@ -0,0 +1,76 @@ +module Data.Blockchain.Core.Types.BlockchainConfigSpec (spec) where + +import TestUtil + +import Data.Monoid ((<>)) +import qualified Data.Time.Clock as Time + +import Data.Blockchain.Core.Types +import Data.Blockchain.Core.Util.Hex + +testConfig :: BlockchainConfig +testConfig = BlockchainConfig + { initialDifficulty = Difficulty 1000 + , difficulty1Target = hex256LeadingZeros 2 + , targetSecondsPerBlock = 60 + , difficultyRecalculationHeight = 10 + , initialMiningReward = 100 + , miningRewardHalvingHeight = 100 + } + +spec :: Spec +spec = describe "Data.Blockchain.Core.Types.BlockchainConfig" $ do + describe "targetReward" $ do + it "should produce the correct reward" $ + and [ targetReward testConfig 0 == 100 + , targetReward testConfig 99 == 100 + , targetReward testConfig 100 == 50 + , targetReward testConfig 101 == 50 + , targetReward testConfig 300 == 12 + , targetReward testConfig 600 == 1 + , targetReward testConfig 700 == 0 + , targetReward testConfig 800 == 0 + ] + + prop "should always find a valid reward" $ + \conf height -> + let reward = targetReward conf height + in reward >= 0 && reward <= initialMiningReward conf + + prop "should always use initial reward if recalc height it zero" $ + \conf height -> + let conf' = conf { miningRewardHalvingHeight = 0 } + in targetReward conf' height == initialMiningReward conf + + describe "targetDifficulty" $ do + prop "should use initial config when no blocks" $ + \conf -> targetDifficulty conf mempty === initialDifficulty conf + + prop "should correctly increase difficulty" $ + \block -> targetDifficulty testConfig (blocksWithOffset 60 block) === Difficulty 10000 + + prop "should correctly decrease difficulty" $ + \block -> targetDifficulty testConfig (blocksWithOffset 6000 block) === Difficulty 100 + + propWithSize 20 "should produce the correct difficulty when not recalculating" $ + \(NonEmpty blocks) conf -> + -- Pretty complex example, can it be cleaned up? + difficultyRecalculationHeight conf /= 0 && + targetSecondsPerBlock conf /= 0 && + length blocks `mod` fromIntegral (difficultyRecalculationHeight conf) /= 0 + ==> targetDifficulty conf blocks === difficulty (blockHeader $ last blocks) + + prop "should always find a valid difficulty" $ + \conf blocks -> targetDifficulty conf blocks >= minBound + +blocksWithOffset :: Time.NominalDiffTime -> Block -> [Block] +blocksWithOffset diffTime (Block header coinbase txs) = + replicate 9 block <> pure lastBlock + where + block = Block (header { difficulty = initialDifficulty testConfig }) coinbase txs + endTime = Time.addUTCTime diffTime $ time header + lastBlock = setTime endTime block + + +setTime :: Time.UTCTime -> Block -> Block +setTime t (Block header tx txs) = Block (header {time = t}) tx txs diff --git a/test/Data/Blockchain/Core/Types/DifficultySpec.hs b/test/Data/Blockchain/Core/Types/DifficultySpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Core/Types/DifficultySpec.hs @@ -0,0 +1,16 @@ +module Data.Blockchain.Core.Types.DifficultySpec (spec) where + +import TestUtil + +import qualified Data.Aeson as Aeson + +import Data.Blockchain.Core.Types.Difficulty + +spec :: Spec +spec = + describe "Data.Blockchain.Core.Types.Difficulty" $ do + safeJSONDeserializeSpec (Proxy :: Proxy Difficulty) + roundTripJSONSpec (Proxy :: Proxy Difficulty) + + it "should handle invalid natural values when deserializing" $ once $ + Aeson.decode "[-1]" === (Nothing :: Maybe [Difficulty]) diff --git a/test/Data/Blockchain/Core/Types/TransactionSpec.hs b/test/Data/Blockchain/Core/Types/TransactionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Core/Types/TransactionSpec.hs @@ -0,0 +1,18 @@ +module Data.Blockchain.Core.Types.TransactionSpec (spec) where + +import TestUtil + +import Data.Blockchain.Core.Crypto.ECDSA +import Data.Blockchain.Core.Types.Transaction + +spec :: Spec +spec = + describe "Data.Blockchain.Core.Types.Transaction" $ + propNumTests 5 "should sign round-trip" $ + \val -> ioProperty $ do + (KeyPair pub priv) <- generate + + let txOut = TransactionOut val pub + sig <- signTransaction priv txOut + + return (verifyTransactionSignature sig txOut) diff --git a/test/Data/Blockchain/Core/Util/HexSpec.hs b/test/Data/Blockchain/Core/Util/HexSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Core/Util/HexSpec.hs @@ -0,0 +1,11 @@ +module Data.Blockchain.Core.Util.HexSpec (spec) where + +import TestUtil + +import Data.Blockchain.Core.Util.Hex + +spec :: Spec +spec = + describe "Data.Blockchain.Core.Util.Hex" $ do + safeJSONDeserializeSpec (Proxy :: Proxy Hex256) + roundTripJSONSpec (Proxy :: Proxy Hex256) diff --git a/test/Data/Blockchain/Mining/BlockSpec.hs b/test/Data/Blockchain/Mining/BlockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Blockchain/Mining/BlockSpec.hs @@ -0,0 +1,44 @@ +module Data.Blockchain.Mining.BlockSpec (spec) where + +import TestUtil + +import Data.Blockchain.Core.Blockchain +import Data.Blockchain.Core.Types +import Data.Blockchain.Core.Util.Hex +import Data.Blockchain.Mining.Block + +spec :: Spec +spec = describe "Data.Blockchain.Mining.Block" $ do + context "mineBlock" $ do + propNumTests 5 "should find a block with a valid difficulty" $ + \pubKey -> ioProperty $ do + blockchain <- blockchain3Block + + let config = blockchainConfig blockchain + node = blockchainNode blockchain + -- use relatively low diff1 here to allow test to complete in a reasonable amount of time + diff1 = hex256LeadingZeros 2 + config' = config { difficulty1Target = diff1 } + blockchain' = validate' (construct config' node) + + (Block header _ _) <- throwLeft <$> mineBlock pubKey mempty blockchain' + + return (blockHeaderHashDifficulty diff1 header >= initialDifficulty config) + + propNumTests 5 "should fail if passed invalid transactions" $ + \pubKey (NonEmpty txs) -> ioProperty $ do + blockchain <- blockchain3Block + + res <- mineBlock pubKey txs blockchain + + return (res === Left InvalidTransactionList) + + context "mineGenesisBlock" $ + propNumTests 5 "should find an initial block with a valid difficulty" $ + \config -> ioProperty $ do + let diff1 = hex256LeadingZeros 2 + config' = config { difficulty1Target = diff1, initialDifficulty = Difficulty 1 } + + (Block header _ _) <- mineGenesisBlock config' + + return (blockHeaderHashDifficulty diff1 header >= initialDifficulty config') diff --git a/test/Integration/Mining.hs b/test/Integration/Mining.hs new file mode 100644 --- /dev/null +++ b/test/Integration/Mining.hs @@ -0,0 +1,128 @@ +module Integration.Mining + ( mineTestChain + ) where + +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.MVar as MVar +import Control.Monad (forM, void) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid ((<>)) +import qualified Data.Time.Clock as Time + +import qualified Data.Blockchain.Core.Blockchain as B +import qualified Data.Blockchain.Core.Crypto as Crypto +import qualified Data.Blockchain.Core.Types as B +import qualified Data.Blockchain.Mining.Block as Mining +import qualified Data.Blockchain.Mining.Blockchain as Mining + +data MinerSpec = MinerSpec + { mid :: Int + , pubKey :: Crypto.PublicKey + , receiveBlock :: IO B.Block + , sendBlock :: B.Block -> IO () + , persistBlockchain :: B.Blockchain B.Validated -> IO () + } + + +mineTestChain :: Int -> IO () +mineTestChain miners = runTestMultiMiner miners config persist + where + persist i = writeJSON $ "data/test_blockchain_" <> show i <> ".json" + config = B.defaultConfig + { B.initialMiningReward = 500 + , B.difficultyRecalculationHeight = 10 + , B.miningRewardHalvingHeight = 20 + } + + +runTestMultiMiner + :: Int -> B.BlockchainConfig + -> (Int -> B.Blockchain B.Validated -> IO ()) -> IO () +runTestMultiMiner numMiners config persist = do + putStrLn "Creating blockchain and mining genesis block" + blockchain <- Mining.createBlockchain config + + let idList = [1..numMiners] + + vars <- mapM (const MVar.newEmptyMVar) idList + + let sends = MVar.putMVar <$> vars + receives = MVar.takeMVar <$> (tail vars <> pure (head vars)) + specs = zip3 sends receives idList + + miners <- forM specs $ \(sendBlock, receiveBlock, mid) -> do + let persistBlockchain = persist mid + (Crypto.KeyPair pubKey _privKey) <- Crypto.generate + return MinerSpec{..} + + asyncs <- mapM (Async.async . runMinerFakeNetwork blockchain) miners + void (Async.waitAny asyncs) + + +runMinerFakeNetwork :: B.Blockchain B.Validated -> MinerSpec -> IO () +runMinerFakeNetwork blockchain spec@(MinerSpec mid _pubKey receive send persist) = do + miningThread <- Async.async $ do + block <- runMining spec blockchain + log' "Found block, broadcasting to other miners" + send block + + case B.addBlock block blockchain of + Right blockchain' -> return blockchain' + Left e -> error $ "Mined invalid block: " <> show e + + receiveBlockThread <- Async.async $ do + block <- receive + + case B.addBlock block blockchain of + Right blockchain' -> do + log' "Received valid block. Stopping mining on current block and re-broadcasting." + send block + return blockchain' + Left e -> log' ("Received invalid block - unable to insert block into chain. Reason: " <> show e) >> return blockchain + + blockchain' <- either id id <$> Async.waitEitherCancel miningThread receiveBlockThread + + persist blockchain' + runMinerFakeNetwork blockchain' spec + where + log' s = do + timestamp <- Time.getCurrentTime + putStrLn $ pad 30 (show timestamp) <> " [miner_" <> show mid <> "] " <> s + +runMining :: MinerSpec -> B.Blockchain B.Validated -> IO B.Block +runMining (MinerSpec mid pubKey _ _ _) chain = do + let mainChain = NonEmpty.toList $ B.longestChain chain + chainLength = length mainChain + config = B.blockchainConfig chain + + log' $ "Mining block #" <> show chainLength + -- TODO: bad interface to find diff. Exported interface should just take blockchain. + log' $ "Target difficulty: " <> show (B.targetDifficulty config mainChain) + + start <- Time.getCurrentTime + block <- throwLeft <$> Mining.mineEmptyBlock pubKey chain + end <- Time.getCurrentTime + + let h = Crypto.hash (B.blockHeader block) + + log' "Found next block" + log' $ " Hash: " <> show h + log' $ " Elapsed time: " <> show (Time.diffUTCTime end start) + + return block + where + log' s = do + timestamp <- Time.getCurrentTime + putStrLn $ pad 30 (show timestamp) <> " [miner_" <> show mid <> "] " <> s + +throwLeft :: Show a => Either a b -> b +throwLeft = either (error . show) id + +pad :: Int -> String -> String +pad x str = str <> replicate (x - length str) ' ' + + +writeJSON :: Aeson.ToJSON a => FilePath -> a -> IO () +writeJSON path = Lazy.writeFile path . Aeson.encode diff --git a/test/Integration/Stats.hs b/test/Integration/Stats.hs new file mode 100644 --- /dev/null +++ b/test/Integration/Stats.hs @@ -0,0 +1,80 @@ +module Integration.Stats + ( printStats + ) where + +-- TODO: this module might be useful elsewhere outside of "Test" group + +import qualified Data.HashMap.Strict as H +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid ((<>)) +import Data.Ratio (Ratio) +import qualified Data.Time.Clock as Time +import Data.Word (Word) +import Numeric.Natural (Natural) + +import qualified Data.Blockchain.Core.Blockchain as B +import qualified Data.Blockchain.Core.Types as B + +data BlockchainStats = BlockchainStats + { numBlocks :: Word + , totalTime :: Time.NominalDiffTime + , totalHashes :: Word + , difficultyProgression :: [Natural] + , rewardProgression :: [Word] + , config :: B.BlockchainConfig + } + +printStats :: B.Blockchain B.Validated -> IO () +printStats blockchain = do + let stats = computeStats blockchain + outputs = H.toList $ B.addressValues blockchain + outputsP = List.intercalate "\n" $ (\(k, v) -> show k <> ": " <> show v) <$> outputs + + putStrLn $ List.intercalate "\n" + [ mempty + , "Final test chain mining stats" + , " Length: " <> show (numBlocks stats) + , " Total time: " <> show (totalTime stats) + , " Time per block: " <> show (timePerBlock stats) + , " Total hashes: " <> show (totalHashes stats) + , " Hashes per block: " <> show (hashesPerBlock stats) + , " Hash rate (hash/s): " <> show (hashRate stats) + , " Last difficulty: " <> show (last (difficultyProgression stats)) + , " Difficulty progression: " <> show (difficultyProgression stats) + , " Last reward: " <> show (last (rewardProgression stats)) + , " Reward progression: " <> show (rewardProgression stats) + , mempty + , "Config used" + , show (config stats) + , mempty + , "Current address values" + , outputsP + ] + + +computeStats :: B.Blockchain B.Validated -> BlockchainStats +computeStats blockchain = BlockchainStats{..} + where + numBlocks = fromIntegral (length mainChain) + totalTime = Time.diffUTCTime (B.time lastHeader) (B.time firstHeader) + totalHashes = fromIntegral $ sum $ (succ . B.nonce) <$> headers -- Add 1 to each nonce to account for first hash + mainChain = NonEmpty.toList $ B.longestChain blockchain + headers = B.blockHeader <$> mainChain + coinbaseTxOuts = B.coinbaseTransactionOut . B.coinbaseTransaction <$> mainChain + firstHeader = head headers + lastHeader = last headers + difficultyProgression = List.nub $ (B.unDifficulty . B.difficulty) <$> headers + rewardProgression = List.nub $ (sum . fmap B.value) <$> coinbaseTxOuts + config = B.blockchainConfig blockchain + +timePerBlock :: BlockchainStats -> Time.NominalDiffTime +timePerBlock BlockchainStats{..} = totalTime / fromIntegral numBlocks + +hashesPerBlock :: BlockchainStats -> Word +hashesPerBlock BlockchainStats{..} = totalHashes `div` numBlocks + +-- TODO: better return type? +-- TODO: compute hash rate only for last N blocks +hashRate :: BlockchainStats -> Word +hashRate BlockchainStats{..} = round (fromIntegral totalHashes / realToFrac totalTime :: Ratio Integer) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,41 @@ +module Main where + +import qualified Test.Hspec + +import qualified System.Environment + +import qualified Data.Blockchain.Core.BlockchainSpec +import qualified Data.Blockchain.Core.Builder.TransactionSpec +import qualified Data.Blockchain.Core.Crypto.ECDSASpec +import qualified Data.Blockchain.Core.Crypto.HashSpec +import qualified Data.Blockchain.Core.Crypto.HashTreeSpec +import qualified Data.Blockchain.Core.Types.BlockchainConfigSpec +import qualified Data.Blockchain.Core.Types.DifficultySpec +import qualified Data.Blockchain.Core.Types.TransactionSpec +import qualified Data.Blockchain.Core.Util.HexSpec +import qualified Data.Blockchain.Mining.BlockSpec +import qualified Integration.Mining +import qualified Integration.Stats +import qualified TestUtil + + +main :: IO () +main = System.Environment.getArgs >>= \case + ["mine", x] -> Integration.Mining.mineTestChain (read x) + ["stats", fp] -> readBlockchain fp >>= Integration.Stats.printStats + _ -> mapM_ Test.Hspec.hspec specs + where + readBlockchain = fmap TestUtil.validate' . TestUtil.readJSON + +specs :: [Test.Hspec.Spec] +specs = [ Data.Blockchain.Core.BlockchainSpec.spec + , Data.Blockchain.Core.Builder.TransactionSpec.spec + , Data.Blockchain.Core.Crypto.ECDSASpec.spec + , Data.Blockchain.Core.Crypto.HashSpec.spec + , Data.Blockchain.Core.Crypto.HashTreeSpec.spec + , Data.Blockchain.Core.Types.BlockchainConfigSpec.spec + , Data.Blockchain.Core.Types.DifficultySpec.spec + , Data.Blockchain.Core.Types.TransactionSpec.spec + , Data.Blockchain.Core.Util.HexSpec.spec + , Data.Blockchain.Mining.BlockSpec.spec + ] diff --git a/test/TestData.hs b/test/TestData.hs new file mode 100644 --- /dev/null +++ b/test/TestData.hs @@ -0,0 +1,75 @@ +module TestData + -- blockchains + ( singletonBlockchainUnvalidated + , singletonBlockchain + , blockchain1Block + , blockchain2BlockFork + , blockchain3Block + -- blocks + , genesisBlock + , block1A + , block1ACoinbasePrivateKey + , block1B + , block1BCoinbasePrivateKey + , block2A + , block2ACoinbasePrivateKey + -- utils + , validate' + , addBlock' + , readJSON + , throwLeft + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as Lazy + +import Data.Blockchain.Core.Blockchain +import Data.Blockchain.Core.Crypto +import Data.Blockchain.Core.Types + +-- Test Data ------------------------------------------------------------------------------------------------- + +singletonBlockchainUnvalidated :: IO (Blockchain Unvalidated) +singletonBlockchainUnvalidated = readJSON "data/singleton_blockchain.json" + +singletonBlockchain :: IO (Blockchain Validated) +singletonBlockchain = validate' <$> singletonBlockchainUnvalidated + +blockchain1Block, blockchain2BlockFork, blockchain3Block :: IO (Blockchain Validated) +blockchain1Block = blockchainWithBlock singletonBlockchain block1A +blockchain2BlockFork = blockchainWithBlock blockchain1Block block1B +blockchain3Block = blockchainWithBlock blockchain2BlockFork block2A + +genesisBlock :: IO Block +genesisBlock = nodeBlock . blockchainNode <$> singletonBlockchain + +block1A, block1B, block2A :: IO Block +block1A = readJSON "data/block_1a.json" +block1B = readJSON "data/block_1b.json" +block2A = readJSON "data/block_2a.json" + +block1ACoinbasePrivateKey, block1BCoinbasePrivateKey, block2ACoinbasePrivateKey :: IO PrivateKey +block1ACoinbasePrivateKey = readJSON "data/block_1a_coinbase_private_key.json" +block1BCoinbasePrivateKey = readJSON "data/block_1b_coinbase_private_key.json" +block2ACoinbasePrivateKey = readJSON "data/block_2a_coinbase_private_key.json" + +-- Utils ----------------------------------------------------------------------------------------------------- + +blockchainWithBlock :: IO (Blockchain Validated) -> IO Block -> IO (Blockchain Validated) +blockchainWithBlock chain block = do + c <- chain + b <- block + + return (addBlock' b c) + +validate' :: Blockchain Unvalidated -> Blockchain Validated +validate' = throwLeft . validate + +addBlock' :: Block -> Blockchain Validated -> Blockchain Validated +addBlock' block = throwLeft . addBlock block + +readJSON :: Aeson.FromJSON a => FilePath -> IO a +readJSON path = throwLeft . Aeson.eitherDecode <$> Lazy.readFile path + +throwLeft :: Show a => Either a b -> b +throwLeft = either (error . show) id diff --git a/test/TestUtil.hs b/test/TestUtil.hs new file mode 100644 --- /dev/null +++ b/test/TestUtil.hs @@ -0,0 +1,53 @@ +module TestUtil + ( module X + , Proxy.Proxy(..) + , propWithSize + , propNumTests + , roundTripJSONSpec + , safeJSONDeserializeSpec + ) where + +import Test.Hspec as X +import Test.Hspec.QuickCheck as X +import Test.QuickCheck as X hiding (Result, generate, labels, reason, theException) +import Test.QuickCheck.Property as X + +import Control.DeepSeq +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.Data as Data +import Data.Monoid ((<>)) +import qualified Data.Proxy as Proxy + +import ArbitraryInstances as X +import TestData as X + + +propWithSize :: Testable prop => Int -> String -> prop -> Spec +propWithSize n tag = modifyMaxSize (const n) . prop tag + +propNumTests :: Testable prop => Int -> String -> prop -> Spec +propNumTests n tag = modifyMaxSuccess (const n) . prop tag + +-- Serialization Utils + +roundTripJSONSpec :: (Arbitrary a, Aeson.FromJSON a, Aeson.ToJSON a, Data.Typeable a, Show a, Eq a) => Proxy.Proxy a -> Spec +roundTripJSONSpec proxy = prop ("should round-trip json serialize " <> tag) $ testRoundTripJSON proxy + where + tag = show (Data.typeRep proxy) + +testRoundTripJSON :: (Aeson.FromJSON a, Aeson.ToJSON a, Show a, Eq a) => Proxy.Proxy a -> a -> Property +testRoundTripJSON _ x = Aeson.decode (Aeson.encode x) === Just x + +safeJSONDeserializeSpec :: (Aeson.FromJSON a, Show a, Data.Typeable a) => Proxy.Proxy a -> Spec +safeJSONDeserializeSpec proxy = prop ("should be safe when deserializing " <> tag) $ testSafeJSONDeserialize proxy + where + tag = show (Data.typeRep proxy) + +testSafeJSONDeserialize :: forall a. (Aeson.FromJSON a, Show a) => Proxy.Proxy a -> BS.ByteString -> Bool +testSafeJSONDeserialize _ bs = canEval $ show (Aeson.decodeStrict' json :: Maybe [a]) + where + json = mconcat [ "[\"", bs, "\"]" ] + +canEval :: NFData a => a -> Bool +canEval x = deepseq x True