Blockchain.hs

module Blockchain where

import Control.Monad
import Data.Word
import HashTree
import Hashable32
import PPrint
import Utils

type Address = Hash
type Amount = Word32

coin :: Amount
coin = 1000

data Transaction = Tx
  { txFrom :: Address,
    txTo :: Address,
    txAmount :: Amount
  }
  deriving (Show)

instance Hashable Transaction where
  hash (Tx a b c) = hash [hash a, hash b, hash c]

data Block = Block
  { blockHdr :: BlockHeader,
    blockTxs :: [Transaction]
  }

instance Show Block where
  show (Block hdr txs) = unlines (show hdr : map show txs)

instance Hashable Block where
  hash = hash . blockHdr

data BlockHeader = BlockHeader
  { parent :: Hash,
    coinbase :: Transaction,
    txroot :: Hash, -- root of the Merkle tree
    nonce :: Hash
  }
  deriving (Show)

instance Hashable BlockHeader where
  hash (BlockHeader p c r n) = hash [p, hash c, r, n]

difficulty :: Integer
difficulty = 5

blockReward :: Amount
blockReward = 50 * coin

coinbaseTx :: Address -> Transaction
coinbaseTx miner = Tx {txFrom = 0, txTo = miner, txAmount = blockReward}

validNonce :: BlockHeader -> Bool
validNonce b = (hash b) `mod` (2 ^ difficulty) == 0

type Miner = Address

type Nonce = Word32

mineBlock :: Miner -> Hash -> [Transaction] -> Block
mineBlock miner parent txs = Block (mine miner parent txs 0) txs

mine :: Miner -> Hash -> [Transaction] -> Nonce -> BlockHeader
mine m p t i =
  let cb = coinbaseTx m
      txroot = treeHash $ buildTree $ cb : t
      header = BlockHeader p cb txroot i
   in if validNonce header then header else mine m p t (i + 1)

validChain :: [Block] -> Bool
validChain = isJust . verifyChain

verifyChain :: [Block] -> Maybe Hash
verifyChain [] = Just 0
verifyChain blocks =
  if all (\(x, y) -> isJust $ verifyBlock x $ hash y) (zip blocks (tail blocks))
    then Just $ hash $ head blocks
    else Nothing

verifyBlock :: Block -> Hash -> Maybe Hash
verifyBlock b@(Block hdr txs) parentHash = do
  guard (parent hdr == parentHash)
  guard (txroot hdr == treeHash (buildTree (coinbase hdr : txs)))
  guard (validNonce hdr)
  return (hash b)

data TransactionReceipt = TxReceipt
  { txrBlock :: Hash,
    txrProof :: MerkleProof Transaction
  }
  deriving (Show)

validateReceipt :: TransactionReceipt -> BlockHeader -> Bool
validateReceipt r hdr =
  txrBlock r == hash hdr
    && verifyProof (txroot hdr) (txrProof r)

mineTransactions :: Miner -> Hash -> [Transaction] -> (Block, [TransactionReceipt])
mineTransactions miner parent txs =
  let block = mineBlock miner parent txs
      h = hash block
      tree = buildTree $ (coinbase $ blockHdr block) : txs
   in (block, [TxReceipt h (fromMaybe undefined (buildProof t tree)) | t <- txs])

pprHeader :: BlockHeader -> ShowS
pprHeader self@(BlockHeader parent cb txroot nonce) =
  pprV
    [ p ("hash", VH $ hash self),
      p ("parent", VH $ parent),
      p ("miner", VH $ txTo cb),
      p ("root", VH txroot),
      p ("nonce", nonce)
    ]
  where
    nl = showString "\n"
    p :: Show a => (String, a) -> ShowS
    p = showsPair

pprBlock :: Block -> ShowS
pprBlock (Block header txs) =
  pprHeader header
    . showChar '\n'
    . pprTxs (coinbase header : txs)

pprTx :: Transaction -> ShowS
pprTx tx@(Tx from to amount) =
  pprH
    [ showString "Tx#",
      showsHash (hash tx),
      p ("from", VH from),
      p ("to", VH to),
      p ("amount", amount)
    ]
  where
    p :: Show a => (String, a) -> ShowS
    p = showsPair

pprTxs :: [Transaction] -> ShowS
pprTxs = pprV . map pprTx