Proof of Burn for Cardano

proof-of-burn.hs

---------------------------------------------------------------
--
-- Module      :  Main
-- Copyright   :  (c) 2021 Brian W Bush
-- License     :  MIT
--
-- Maintainer  :  Brian W Bush <[email protected]>
-- Stability   :  Stable
-- Portability :  Portable
--
-- | Implementation of the proof-of-burn algorithm for Cardano.
-- | The `generateBurnAddress` function takes an arbitrary
-- | string as a seed (or tag) and creates a Cardano address
-- | where value is provably unspendable: i.e., no signing key
-- | exists that can witness spending eUTxOs at the address.
-- |
-- | Reference: Kostis Karantias, Aggelos Kiayias, Dionysis
-- | Zindros, "Proof of Burn", Financial Cryptography, 2020.
-- | <https://eprint.iacr.org/2019/1096.pdf>
--
---------------------------------------------------------------


{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}


module Main (
-- ^ Entry
  main
-- ^ Addresses
, generateBurnAddress
) where


import Data.Bits                 (xor)
import Data.ByteString           (ByteString, pack, unpack)
import Cardano.Api.Shelley       (Address(ShelleyAddress),
                                  ShelleyAddr,
                                  serialiseAddress)
import Cardano.Crypto.Hash.Class (hashFromBytes, hashToBytes,
                                  hashWith)
import Cardano.Ledger.BaseTypes  (Network(Mainnet))
import Cardano.Ledger.Credential (Credential(KeyHashObj),
                                  StakeReference(StakeRefNull))
import Cardano.Ledger.Crypto     (StandardCrypto)
import Cardano.Ledger.Keys       (KeyHash(KeyHash),
                                  KeyRole(Payment))


-- | Print an example proof-of-burn address.
-- |
-- | This example creates the following address:
-- | addr1vyxdw4rlu6krp9fwgwcnld6y84wdahg585vrdy67n5urp9qlryntm
main :: IO ()
main =
  let
    tag = "Proof of Burn"
    address = generateBurnAddress tag
  in
    print $ serialiseAddress address


-- | Generate a proof-of-burn address.
generateBurnAddress :: ByteString          -- ^ Any bytestring.
                    -> Address ShelleyAddr -- ^ The address.
generateBurnAddress tag =
  ShelleyAddress 
    Mainnet
    (KeyHashObj . tweakHash $ hashTag tag)
    StakeRefNull


-- | Convert a byte string into a payment key hash.
hashTag :: ByteString                      -- ^ Any bytestring.
        -> KeyHash 'Payment StandardCrypto -- ^ The hash.
hashTag tag = KeyHash $ hashWith (const tag) undefined


-- | Flip the last bit of a payment key hash.
tweakHash :: KeyHash 'Payment StandardCrypto -- ^ The hash.
          -> KeyHash 'Payment StandardCrypto -- ^ Tweaked hash.
tweakHash (KeyHash hashed) =
  let
    original = unpack $ hashToBytes hashed
    tweaked = init original ++ [last original `xor` 1]
    Just tweaked' = hashFromBytes $ pack tweaked
  in
    KeyHash tweaked'