blockchain (empty) → 0.0.0.1
raw patch · 34 files changed
+2262/−0 lines, 34 filesdep +QuickCheckdep +aesondep +asyncsetup-changed
Dependencies added: QuickCheck, aeson, async, base, blockchain, byteable, bytestring, cryptonite, deepseq, either, errors, hashable, hspec, memory, mtl, text, time, transformers, unordered-containers
Files
- LICENSE +30/−0
- README.md +92/−0
- Setup.hs +2/−0
- blockchain.cabal +104/−0
- lib/Data/Blockchain/Core/Blockchain.hs +323/−0
- lib/Data/Blockchain/Core/Builder/Transaction.hs +58/−0
- lib/Data/Blockchain/Core/Crypto.hs +7/−0
- lib/Data/Blockchain/Core/Crypto/ECDSA.hs +131/−0
- lib/Data/Blockchain/Core/Crypto/Hash.hs +65/−0
- lib/Data/Blockchain/Core/Crypto/HashTree.hs +30/−0
- lib/Data/Blockchain/Core/Types.hs +8/−0
- lib/Data/Blockchain/Core/Types/Block.hs +37/−0
- lib/Data/Blockchain/Core/Types/BlockchainConfig.hs +83/−0
- lib/Data/Blockchain/Core/Types/Difficulty.hs +15/−0
- lib/Data/Blockchain/Core/Types/Transaction.hs +80/−0
- lib/Data/Blockchain/Core/Util/Hex.hs +58/−0
- lib/Data/Blockchain/Mining/Block.hs +103/−0
- lib/Data/Blockchain/Mining/Blockchain.hs +21/−0
- test/ArbitraryInstances.hs +117/−0
- test/Data/Blockchain/Core/BlockchainSpec.hs +202/−0
- test/Data/Blockchain/Core/Builder/TransactionSpec.hs +76/−0
- test/Data/Blockchain/Core/Crypto/ECDSASpec.hs +22/−0
- test/Data/Blockchain/Core/Crypto/HashSpec.hs +23/−0
- test/Data/Blockchain/Core/Crypto/HashTreeSpec.hs +33/−0
- test/Data/Blockchain/Core/Types/BlockchainConfigSpec.hs +76/−0
- test/Data/Blockchain/Core/Types/DifficultySpec.hs +16/−0
- test/Data/Blockchain/Core/Types/TransactionSpec.hs +18/−0
- test/Data/Blockchain/Core/Util/HexSpec.hs +11/−0
- test/Data/Blockchain/Mining/BlockSpec.hs +44/−0
- test/Integration/Mining.hs +128/−0
- test/Integration/Stats.hs +80/−0
- test/Main.hs +41/−0
- test/TestData.hs +75/−0
- test/TestUtil.hs +53/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 <num-miners> -- run test mining network+$ ./scripts/test_stats <file-path> -- 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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ blockchain.cabal view
@@ -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
+ lib/Data/Blockchain/Core/Blockchain.hs view
@@ -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
+ lib/Data/Blockchain/Core/Builder/Transaction.hs view
@@ -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')
+ lib/Data/Blockchain/Core/Crypto.hs view
@@ -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
+ lib/Data/Blockchain/Core/Crypto/ECDSA.hs view
@@ -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
+ lib/Data/Blockchain/Core/Crypto/Hash.hs view
@@ -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
+ lib/Data/Blockchain/Core/Crypto/HashTree.hs view
@@ -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
+ lib/Data/Blockchain/Core/Types.hs view
@@ -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
+ lib/Data/Blockchain/Core/Types/Block.hs view
@@ -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
+ lib/Data/Blockchain/Core/Types/BlockchainConfig.hs view
@@ -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
+ lib/Data/Blockchain/Core/Types/Difficulty.hs view
@@ -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)
+ lib/Data/Blockchain/Core/Types/Transaction.hs view
@@ -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
+ lib/Data/Blockchain/Core/Util/Hex.hs view
@@ -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
+ lib/Data/Blockchain/Mining/Block.hs view
@@ -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 }
+ lib/Data/Blockchain/Mining/Blockchain.hs view
@@ -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
+ test/ArbitraryInstances.hs view
@@ -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
+ test/Data/Blockchain/Core/BlockchainSpec.hs view
@@ -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
+ test/Data/Blockchain/Core/Builder/TransactionSpec.hs view
@@ -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
+ test/Data/Blockchain/Core/Crypto/ECDSASpec.hs view
@@ -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
+ test/Data/Blockchain/Core/Crypto/HashSpec.hs view
@@ -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
+ test/Data/Blockchain/Core/Crypto/HashTreeSpec.hs view
@@ -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
+ test/Data/Blockchain/Core/Types/BlockchainConfigSpec.hs view
@@ -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
+ test/Data/Blockchain/Core/Types/DifficultySpec.hs view
@@ -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])
+ test/Data/Blockchain/Core/Types/TransactionSpec.hs view
@@ -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)
+ test/Data/Blockchain/Core/Util/HexSpec.hs view
@@ -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)
+ test/Data/Blockchain/Mining/BlockSpec.hs view
@@ -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')
+ test/Integration/Mining.hs view
@@ -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
+ test/Integration/Stats.hs view
@@ -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)
+ test/Main.hs view
@@ -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+ ]
+ test/TestData.hs view
@@ -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
+ test/TestUtil.hs view
@@ -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