Building a Simple Haskell Blockchain: Types, Mining, and Persistence

Bitcoin and Ethereum provide a decentralized way to handle funds, contracts, and ownership tokens. From a technical perspective they consist of many moving parts and offer a good demonstration language for programming.

This tutorial develops a simple block data structure to demonstrate in Haskell:

Write binary serializers and deserializers.

Use cryptographic primitives to compute hashes.

Automatically adjust miner difficulty based on budgeted time.

We name the project Haskoin. Note that until future protocol upgrades it does not address network or wallet security concerns.

What is a blockchain?

Before writing any application software the first step is to decide on the data structure. Whether in Haskell, Perl, C, or SQL we need to place the main types and type‑class instances in their respective modules.

{-# LANGUAGE GeneralizedNewtypeDeriving, NoImplicitPrelude, DeriveTraversable, DeriveDataTypeable, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-}
module Haskoin.Types where
import Protolude
import Crypto.Hash
import Control.Comonad.Cofree
import Data.Data
import qualified Data.Vector as V

newtype Account = Account Integer deriving (Eq, Show, Num)

data Transaction = Transaction {
  _from   :: Account,
  _to     :: Account,
  _amount :: Integer
  } deriving (Eq, Show)

newtype BlockF a = Block (V.Vector a) deriving (Eq, Show, Foldable, Traversable, Functor, Monoid)

type Block = BlockF Transaction
type HaskoinHash = Digest SHA1

data BlockHeader = BlockHeader {
  _miner       :: Account,
  _parentHash  :: HaskoinHash
  } deriving (Eq, Show)

data MerkleF a = Genesis
            | Node BlockHeader a
            deriving (Eq, Show, Functor, Traversable, Foldable)

type Blockchain = Cofree MerkleF Block

MerkleF

is a higher‑order Merkle type that adds a layer on top of other types. Cofree MerkleF Block does two things: it recursively applies MerkleF to generate a type for every depth of the Merkle tree, and it annotates each node with a Block value.

When using Cofree, the annotation operator anno :< xf builds such an annotated value.

It is useful to think of a “reverse tree” where each node knows its parent rather than its children. If each node knew its children, adding a new block at the end would require modifying every node. Therefore MerkleF generates a chain rather than a tree. Protolude is a recent replacement for Prelude that I use in medium‑sized projects. Prelude has many backward‑compatibility issues, so many people disable it with the NoImplicitPrelude language extension and introduce a custom replacement.

Why choose the rather exotic MerkleF type instead of the simpler type below?

newtype Block = Block (V.Vector Transaction)

data Blockchain = Genesis Block
                | Node Block BlockHeader Blockchain

The main reason is to obtain Functor, Traversable, and Foldable instances automatically, which let us work with our Merkle tree without writing any boilerplate code. For example, given a blockchain we can traverse it easily.

import qualified Data.Vector as V
let genesis_block = Block (V.fromList [])
let block1 = Block (V.fromList [Transaction 0 1 1000])
let genesis_chain = genesis_block :< Genesis

Below is how to extract all transaction information:

let txns = toList $ mconcat $ toList chain2
-- [Transaction {_from = Account 0, _to = Account 1, _amount = 1000}, ...]
let totalVolume = sum $ map _amount txns
-- 2000

I tested the above with stack ghc in an interactive prompt.

The real block header contains many useful fields such as timestamps or random nonces. We can add them to BlockHeader as needed.

Building the chain

A collection of abstract types is not very useful by itself. We need a way to mine new blocks to do anything interesting. In other words, we define mineOn and makeGenesis:

module Haskoin.Mining where
type TransactionPool = IO [Transaction]

mineOn :: TransactionPool -> Account -> Blockchain -> IO Blockchain
mineOn pendingTransactions minerAccount root = undefined

makeGenesis :: IO Blockchain
makeGenesis = undefined

The most primitive block is simple; it even lacks a header:

makeGenesis = return $ Block (V.fromList []) :< Genesis

Without any difficulty or transaction limits we can write a mineOn method, and it is safe as long as we know how to compute a parent hash:

mineOn :: TransactionPool -> Account -> Blockchain -> IO Blockchain
mineOn pendingTransactions minerAccount parent = do
  ts <- pendingTransactions
  let block = Block (V.fromList ts)
  let header = BlockHeader {
        _miner = minerAccount,
        _parentHash = hash parent
        }
  return $ block :< Node header parent

hash :: Blockchain -> HaskoinHash
hash = undefined

Crypto.Hash

offers several ways to compute a hash. We chose type HaskoinHash = Digest SHA1. To serialize and deserialize a Blockchain we use the binary library, which provides the Binary class.

Writing the instances by hand is not difficult, but a benefit of recursive types is that the compiler can generate Binary instances for us. Below is the full code for serialization and deserialization of the required types.

Only the deserialize and serialize functions are exported to keep the module concise. We then delegate to Data.Binary.decode and Data.Binary.encode. Generic is a lightweight “syntax tree” that lets serializers (JSON, XML, Binary, etc.) and many other type‑class users provide useful default definitions. The Haskell wiki has an overview of using binary with Generic instances.

We must manually write a Binary instance for HaskoinHash because Digest SHA1 from Crypto.Hash does not provide a Generic instance. This is straightforward since a digest is just a byte string.

Here is how to use the serializers in mineOn:

import Crypto.Hash (hashlazy)

mineOn :: TransactionPool -> Account -> Blockchain -> IO Blockchain
mineOn pendingTransactions minerAccount parent = do
  ts <- pendingTransactions
  let block = Block (V.fromList ts)
  let header = BlockHeader {
        _miner = minerAccount,
        _parentHash = hashlazy $ encode parent,
        _nonce = 0,
        _minedAt = getPOSIXTime
        }
  return $ block :< Node header parent

Testing the actual work:

testMining :: IO Blockchain
testMining = do
  let txnPool = return []
  chain <- makeGenesis
  chain <- mineOn txnPool 0 chain
  chain <- mineOn txnPool 0 chain
  chain <- mineOn txnPool 0 chain
  chain <- mineOn txnPool 0 chain
  chain <- mineOn txnPool 0 chain
  return chain

If you test the serialization code at home you might prefer the base16-bytestring library to convert ByteString s to hexadecimal ASCII:

import qualified Data.ByteString.Base16.Lazy as BSL
chain <- testMining
BSL.encode $ encode chain

Mining

There are several mining‑related problems:

People can have negative balances, so they could create a “scapegoat” account with unlimited funds.

There is no transaction limit, so a miner could create a huge block that exhausts all memory.

We always mine empty blocks, so no one can exchange money.

There is no difficulty, so miners cannot prove they have done any work.

To solve #1 we need the balance of every account that appears in the blocks we are mining. We compute all possible balances:

blockReward = 1000
balances :: Blockchain -> M.Map Account Integer
balances bc =
  let txns = toList $ mconcat $ toList bc
      debits = map (\Transaction{_from = acc, _amount = amount} -> (acc, -amount)) txns
      credits = map (\Transaction{_to = acc, _amount = amount} -> (acc, amount)) txns
      minings = map (\h -> (_minerAccount h, blockReward)) $ headers bc
  in M.fromListWith (+) $ debits ++ credits ++ minings

Once we have a parent blockchain we can filter out invalid transactions:

validTransactions :: Blockchain -> [Transaction] -> [Transaction]
validTransactions bc txns =
  let accounts = balances bc
      validTxn txn = case M.lookup (_from txn) accounts of
        Nothing -> False
        Just balance -> balance >= _amount txn
  in filter validTxn txns

To address #2 we limit the number of transactions a miner can include by using a constant globalTransactionLimit = 1000. The limit is applied only to newly mined blocks.

To address #4 we add a nonce field and a timestamp _minedAt to BlockHeader so that miners can iterate until they find a hash that satisfies the required difficulty.

import Data.Time.Clock.POSIX

data BlockHeader = BlockHeader {
  _miner       :: Account,
  _parentHash  :: HaskoinHash,
  _nonce       :: Integer,
  _minedAt     :: POSIXTime
  } deriving (Eq, Show)

instance Binary POSIXTime where
  get = fromInteger <$> (get :: Get Integer)
  put x = put (round x :: Integer)

globalTransactionLimit = 1000

mineOn :: TransactionPool -> Account -> Blockchain -> IO Blockchain
mineOn pendingTransactions minerAccount parent = do
  ts <- pendingTransactions
  ts <- return $ validTransactions parent ts
  ts <- return $ take globalTransactionLimit ts
  loop ts 0
  where
    loop ts nonce = do
      now <- getPOSIXTime
      let header = BlockHeader {
            _miner = minerAccount,
            _parentHash = hashlazy $ encode parent,
            _nonce = nonce,
            _minedAt = now
            }
          block = Block (V.fromList ts)
          candidate = block :< Node header parent
      if difficulty candidate < desiredDifficulty parent
        then return candidate
        else loop ts (nonce + 1)

Difficulty is defined as the integer representation of the block hash:

import Crypto.Number.Serialize (os2ip)

difficulty :: Blockchain -> Integer
difficulty bc = os2ip $ (hashlazy $ encode bc :: HaskoinHash)

We compute the target difficulty by averaging the timestamps of the last 100 blocks:

numBlocksToCalculateDifficulty = 100
blockTimeAverage :: Blockchain -> NominalDiffTime
blockTimeAverage bc = average $ zipWith (-) times (tail times)
  where
    times = take numBlocksToCalculateDifficulty $ map _minedAt $ headers bc

headers :: Blockchain -> [BlockHeader]
headers Genesis = []
headers (_ :< Node x next) = x : headers next

average :: (Foldable f, Num a, Fractional a) => f a -> a
average xs = sum xs / (if d == 0 then 1 else d) where d = fromIntegral $ length xs

Assuming a target block time of 10 seconds and a current average of 2 seconds, the adjustment factor is 5, meaning we accept only one‑fifth of the original difficulty.

genesisBlockDifficulty = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
targetTime = 10

desiredDifficulty :: Blockchain -> Integer
desiredDifficulty x = round $ loop x
  where
    loop (_ :< Genesis) = genesisBlockDifficulty
    loop x@(_ :< Node _ xs) = oldDifficulty / adjustmentFactor
      where
        oldDifficulty = loop xs
        adjustmentFactor = min 4.0 $ targetTime `safeDiv` blockTimeAverage x

Example mining times (around 10 s) show the adjustment in action.

Persistence

We store the blockchain on disk and provide three command‑line tools:

Mine new blocks.

List account balances.

(Future) Explore the chain via a web interface.

Mining tool (simplified):

{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
module Haskoin.Cli.Mine where
import Haskoin.Mining
import Haskoin.Serialization
import Haskoin.Types
import Protolude
import System.Environment
import Data.Binary
import qualified Data.ByteString.Lazy as BSL
import System.Directory
import Prelude (read)

defaultChainFile = "main.chain"
defaultAccount = "10"

main :: IO ()
main = do
  args <- getArgs
  let (filename, accountS) = case args of
        [] -> (defaultChainFile, defaultAccount)
        [f] -> (f, defaultAccount)
        [f, a] -> (f, a)
        _ -> panic "Usage: mine [filename] [account]"
  let swapFile = filename ++ ".tmp"
  let txnPool = return []
  let account = Account $ read accountS
  forever $ do
    chain <- loadOrCreate filename makeGenesis :: IO Blockchain
    newChain <- mineOn txnPool account chain
    encodeFile swapFile newChain
    copyFile swapFile filename
    print "Block mined and saved!"

loadOrCreate :: Binary a => FilePath -> IO a -> IO a
loadOrCreate filename init = do
  exists <- doesFileExist filename
  if exists
    then decodeFile filename
    else do
      x <- init
      encodeFile filename x
      return x

Balance‑listing tool:

{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
module Haskoin.Cli.ListBalances where
import Haskoin.Mining
import Haskoin.Serialization
import Haskoin.Types
import Protolude
import System.Environment
import Data.Binary
import qualified Data.Map as M

defaultChainFile = "main.chain"

main :: IO ()
main = do
  args <- getArgs
  let filename = case args of
        [] -> defaultChainFile
        [f] -> f
        _ -> panic "Usage: list-balances [filename]"
  chain <- decodeFile filename :: IO Blockchain
  forM_ (M.toAscList $ balances chain) $ \(account, balance) -> do
    print (account, balance)

Running the tools yields output such as:

$ stack exec list-balances
(Account 10,23000)

It is clear that stack exec mine mined 23 blocks.

Conclusion

We have developed a simple blockchain data structure in Haskell. The source code is available on GitHub.

Future Haskoin articles may cover:

Using networking and concurrency primitives to build a peer‑to‑peer network.

Protecting wallet accounts from unauthorized transfers.

Building a blockchain explorer website.

GPU‑accelerated hashing.

FPGA‑accelerated hashing.

Future cryptocurrency‑related articles may cover:

Proof‑of‑Work versus Proof‑of‑Stake and the underlying logic.

Adding a Turing‑complete scripting language.

Better command‑line option parsing.

Constructing a Bitcoin transaction.