{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}

-- |
-- Module      : Crypto.Hash.CompactSparseMerkleTree
-- Description : Compact sparse merkle trees
-- Copyright   : (c) Tochi Obudulu 2022
-- License     : BSD-3
-- Maintainer  : tochicool@gmail.com
-- Portability : portable
-- Stability   : experimental
--
--
-- = Compact Sparse Merkle Trees
--
-- The @'CompactSparseMerkleTree' i alg a@ type represents a merkle tree of size
-- @i@ containing elements of type @a@ authenticated with a secure cryptographic
-- hash function @alg@. This allows for the novel generation and verification of
-- memory efficient cryptographic zero-knowledge proofs of inclusion and
-- /exclusion/ of elements in the tree. Most operations require that @a@ be an
-- instance of the 'ByteArrayAccess' class and @alg@ be an instance of the
-- 'HashAlgorithm' class.
--
-- This module is intended to be imported qualified:
--
-- >  import Crypto.Hash.CompactSparseMerkleTree (CSMT)
-- >  import qualified Crypto.Hash.CompactSparseMerkleTree as CSMT
--
--
-- == Warning
--
-- The size of the tree obviously cannot exceed the size of the image of the
-- hash algorithm @2^(8 * hashDigestSize alg)@. The word length of the hash
-- digest for the algorithm must not exceed @maxBound :: Int@. Violation of
-- these limits are not detected and a breach implies undefined behaviour.
--
--
-- == Implementation
--
-- The implementation of 'CompactSparseMerkleTree' is based on /compact/ sparse
-- merkle trees as described by:
--
--    * Faraz Haider. "Compact sparse merkle trees.",
--      Cryptology ePrint Archive, October 2018,
--      <https://eprint.iacr.org/2018/955>.
--
-- Asymptotic bounds for the average case time complexity are given with the
-- assumption that the supplied hash function acts as a random oracle under the
-- random oracle model and that the compact sparse merkle tree is 'valid'. In
-- practice, the probability that the observed complexity differs from the
-- average case is vanishingly small.
--
-- Additionally, this implementation enforces /domain separation/ for the inputs
-- to the hash algorithm @alg@ to provide the proofs with resistance to second
-- preimage attacks. Inputs to hashes for leaf and parent nodes are prefixed
-- with the bytes @0x00@ and @0x01@ respectively before applying the hash
-- algorithm.
module Crypto.Hash.CompactSparseMerkleTree
  ( -- * CompactSparseMerkleTree Type
    CSMT,
    CompactSparseMerkleTree (..),
    Size (..),

    -- * Construction
    empty,
    singleton,
    fromList,

    -- * Insertion
    insert,

    -- * Deletion
    delete,

    -- * Query
    lookup,
    member,
    notMember,

    -- * Min\/Max
    minimumDigest,
    maximumDigest,

    -- * Proofs
    MembershipProof (..),
    Proof (..),
    Direction (..),
    ProofType (..),
    isInclusionProof,
    isExclusionProof,

    -- ** Proof construction
    membershipProof,

    -- ** Proof verification
    MerkleRoot (..),
    merkleRoot,
    validProof,
    validInclusionProof,
    validExclusionProof,
    valid,

    -- * Debugging
    depth,
    toTree,
    drawTree,
  )
where

import Crypto.Hash (Digest, HashAlgorithm, hashFinalize, hashInit, hashUpdate, hashUpdates)
import Crypto.Hash.CompactSparseMerkleTree.DataNode (DataNode)
import qualified Crypto.Hash.CompactSparseMerkleTree.DataNode as DN
import Data.Bifunctor (first)
import Data.Bits (FiniteBits (countLeadingZeros))
import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import Data.Foldable (foldl', toList)
import Data.Functor (void)
import Data.Functor.Classes (Eq1 (liftEq), Ord1 (liftCompare))
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Maybe (mapMaybe)
import Data.Ord (comparing)
import Data.Tree (Tree)
import qualified Data.Tree as Tree
import Prelude hiding (lookup)

-- | A compact sparse merkle tree of size @i@ with values @a@ authenticated over
-- the algorithm @alg@.
type CSMT = CompactSparseMerkleTree

-- | A compact sparse merkle tree of size @i@ with values @a@ authenticated over
-- the algorithm @alg@.
data CompactSparseMerkleTree (i :: Size) alg a where
  -- | The empty tree.
  Nil :: CSMT 'Empty alg a
  -- | A leaf node.
  Leaf ::
    { -- | The hash digest of the data element.
      CSMT 'NonEmpty alg a -> Digest alg
digest :: Digest alg,
      -- | The data value.
      CSMT 'NonEmpty alg a -> a
value :: a
    } ->
    CSMT 'NonEmpty alg a
  -- | A parent node.
  Parent ::
    { -- | The left non-empty subtree.
      CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a,
      -- | The hash digest of the concatenation of the left and right subtree digests.
      digest :: Digest alg,
      -- | The maximum digest in the tree.
      CSMT 'NonEmpty alg a -> Digest alg
maxDigest :: Digest alg,
      -- | The right non-empty subtree.
      CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
    } ->
    CSMT 'NonEmpty alg a

-- | The size of a compact sparse merkle tree.
data Size
  = -- | The empty tree
    Empty
  | -- | A non-empty tree
    NonEmpty

deriving instance (Show a) => Show (CSMT i alg a)

deriving instance Foldable (CSMT i alg)

deriving instance (Eq a) => Eq (CSMT i alg a)

deriving instance (Ord a) => Ord (CSMT i alg a)

instance Eq1 (CSMT i alg) where
  liftEq :: (a -> b -> Bool) -> CSMT i alg a -> CSMT i alg b -> Bool
liftEq a -> b -> Bool
eq CSMT i alg a
m CSMT i alg b
n = (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq (CSMT i alg a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CSMT i alg a
m) (CSMT i alg b -> [b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CSMT i alg b
n)

instance Ord1 (CSMT i alg) where
  liftCompare :: (a -> b -> Ordering) -> CSMT i alg a -> CSMT i alg b -> Ordering
liftCompare a -> b -> Ordering
cmp CSMT i alg a
m CSMT i alg b
n = (a -> b -> Ordering) -> [a] -> [b] -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp (CSMT i alg a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CSMT i alg a
m) (CSMT i alg b -> [b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CSMT i alg b
n)

-- | The empty tree.
--
-- Worst case Θ(1).
empty :: CSMT 'Empty alg a
empty :: CSMT 'Empty alg a
empty = CSMT 'Empty alg a
forall alg a. CSMT 'Empty alg a
Nil

-- | Create a singleton tree.
--
-- Worst case Θ(1).
singleton :: (ByteArrayAccess a, HashAlgorithm alg) => a -> CSMT 'NonEmpty alg a
singleton :: a -> CSMT 'NonEmpty alg a
singleton a
x = Digest alg -> a -> CSMT 'NonEmpty alg a
forall alg a. Digest alg -> a -> CSMT 'NonEmpty alg a
singletonDigest (a -> Digest alg
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Digest a
hashLeaf a
x) a
x

singletonDigest :: Digest alg -> a -> CSMT 'NonEmpty alg a
singletonDigest :: Digest alg -> a -> CSMT 'NonEmpty alg a
singletonDigest Digest alg
h a
x = Leaf :: forall alg a. Digest alg -> a -> CSMT 'NonEmpty alg a
Leaf {$sel:digest:Nil :: Digest alg
digest = Digest alg
h, $sel:value:Nil :: a
value = a
x}

-- | Insert an element in a tree. If the tree already contains an element whose
-- hash is equal to the given value, it is replaced with the new value.
--
-- Average case Θ(log n), Worst case Θ(n) where n is the size of the tree.
insert :: (ByteArrayAccess a, HashAlgorithm alg) => a -> CSMT i alg a -> CSMT 'NonEmpty alg a
insert :: a -> CSMT i alg a -> CSMT 'NonEmpty alg a
insert a
x = Digest alg -> a -> CSMT i alg a -> CSMT 'NonEmpty alg a
forall a alg (i :: Size).
(ByteArrayAccess a, HashAlgorithm alg) =>
Digest alg -> a -> CSMT i alg a -> CSMT 'NonEmpty alg a
insertDigest (a -> Digest alg
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Digest a
hashLeaf a
x) a
x

insertDigest :: (ByteArrayAccess a, HashAlgorithm alg) => Digest alg -> a -> CSMT i alg a -> CSMT 'NonEmpty alg a
insertDigest :: Digest alg -> a -> CSMT i alg a -> CSMT 'NonEmpty alg a
insertDigest Digest alg
h a
x = \case
  CSMT i alg a
Nil -> Digest alg -> a -> CSMT 'NonEmpty alg a
forall alg a. Digest alg -> a -> CSMT 'NonEmpty alg a
singletonDigest Digest alg
h a
x
  root :: CSMT i alg a
root@Leaf {} ->
    let newLeaf :: CSMT 'NonEmpty alg a
newLeaf = Digest alg -> a -> CSMT 'NonEmpty alg a
forall alg a. Digest alg -> a -> CSMT 'NonEmpty alg a
singletonDigest Digest alg
h a
x
     in case Digest alg
h Digest alg -> Digest alg -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest CSMT i alg a
CSMT 'NonEmpty alg a
root of
          Ordering
LT -> CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT 'NonEmpty alg a
newLeaf CSMT i alg a
CSMT 'NonEmpty alg a
root
          Ordering
EQ -> Digest alg -> a -> CSMT 'NonEmpty alg a
forall alg a. Digest alg -> a -> CSMT 'NonEmpty alg a
singletonDigest Digest alg
h a
x
          Ordering
GT -> CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT i alg a
CSMT 'NonEmpty alg a
root CSMT 'NonEmpty alg a
newLeaf
  root :: CSMT i alg a
root@Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left, CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right} ->
    case Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
forall alg a.
Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
compareSubTrees Digest alg
h CSMT 'NonEmpty alg a
left CSMT 'NonEmpty alg a
right of
      Ordering
EQ ->
        let newLeaf :: CSMT 'NonEmpty alg a
newLeaf = Digest alg -> a -> CSMT 'NonEmpty alg a
forall alg a. Digest alg -> a -> CSMT 'NonEmpty alg a
singletonDigest Digest alg
h a
x
            minKey :: Digest alg
minKey = Digest alg -> Digest alg -> Digest alg
forall a. Ord a => a -> a -> a
min (CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest CSMT 'NonEmpty alg a
left) (CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest CSMT 'NonEmpty alg a
right)
         in case Digest alg
h Digest alg -> Digest alg -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Digest alg
minKey of
              Ordering
LT -> CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT 'NonEmpty alg a
newLeaf CSMT i alg a
CSMT 'NonEmpty alg a
root
              Ordering
__ -> CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT i alg a
CSMT 'NonEmpty alg a
root CSMT 'NonEmpty alg a
newLeaf
      Ordering
LT -> CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent (Digest alg -> a -> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall a alg (i :: Size).
(ByteArrayAccess a, HashAlgorithm alg) =>
Digest alg -> a -> CSMT i alg a -> CSMT 'NonEmpty alg a
insertDigest Digest alg
h a
x CSMT 'NonEmpty alg a
left) CSMT 'NonEmpty alg a
right
      Ordering
GT -> CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT 'NonEmpty alg a
left (Digest alg -> a -> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall a alg (i :: Size).
(ByteArrayAccess a, HashAlgorithm alg) =>
Digest alg -> a -> CSMT i alg a -> CSMT 'NonEmpty alg a
insertDigest Digest alg
h a
x CSMT 'NonEmpty alg a
right)

-- | Delete an element from a tree if such an element exists.
--
-- Average case Θ(log n), Worst case Θ(n) where n is the size of the tree.
delete :: (ByteArrayAccess a, HashAlgorithm alg) => a -> CSMT i alg a -> (forall j. CSMT j alg a -> b) -> b
delete :: a -> CSMT i alg a -> (forall (j :: Size). CSMT j alg a -> b) -> b
delete a
x = Digest alg
-> CSMT i alg a -> (forall (j :: Size). CSMT j alg a -> b) -> b
forall alg (i :: Size) a b.
HashAlgorithm alg =>
Digest alg
-> CSMT i alg a -> (forall (j :: Size). CSMT j alg a -> b) -> b
deleteDigest (a -> Digest alg
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Digest a
hashLeaf a
x)

deleteDigest :: HashAlgorithm alg => Digest alg -> CSMT i alg a -> (forall j. CSMT j alg a -> b) -> b
deleteDigest :: Digest alg
-> CSMT i alg a -> (forall (j :: Size). CSMT j alg a -> b) -> b
deleteDigest Digest alg
h CSMT i alg a
root forall (j :: Size). CSMT j alg a -> b
returnTree = case CSMT i alg a
root of
  Nil {} -> CSMT i alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree CSMT i alg a
root
  Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest}
    | Digest alg
h Digest alg -> Digest alg -> Bool
forall a. Eq a => a -> a -> Bool
== Digest alg
digest -> CSMT 'Empty alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree CSMT 'Empty alg a
forall alg a. CSMT 'Empty alg a
empty
    | Bool
otherwise -> CSMT i alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree CSMT i alg a
root
  Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left, CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right} ->
    case Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
forall alg a.
Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
compareSubTrees Digest alg
h CSMT 'NonEmpty alg a
left CSMT 'NonEmpty alg a
right of
      Ordering
EQ -> CSMT i alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree CSMT i alg a
root
      Ordering
LT -> Digest alg
-> CSMT 'NonEmpty alg a
-> (forall (j :: Size). CSMT j alg a -> b)
-> b
forall alg (i :: Size) a b.
HashAlgorithm alg =>
Digest alg
-> CSMT i alg a -> (forall (j :: Size). CSMT j alg a -> b) -> b
deleteDigest Digest alg
h CSMT 'NonEmpty alg a
left ((forall (j :: Size). CSMT j alg a -> b) -> b)
-> (forall (j :: Size). CSMT j alg a -> b) -> b
forall a b. (a -> b) -> a -> b
$ \case
        Nil {} -> CSMT 'NonEmpty alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree CSMT 'NonEmpty alg a
right
        left' :: CSMT j alg a
left'@Leaf {} -> CSMT 'NonEmpty alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree (CSMT 'NonEmpty alg a -> b) -> CSMT 'NonEmpty alg a -> b
forall a b. (a -> b) -> a -> b
$ CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT j alg a
CSMT 'NonEmpty alg a
left' CSMT 'NonEmpty alg a
right
        left' :: CSMT j alg a
left'@Parent {} -> CSMT 'NonEmpty alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree (CSMT 'NonEmpty alg a -> b) -> CSMT 'NonEmpty alg a -> b
forall a b. (a -> b) -> a -> b
$ CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT j alg a
CSMT 'NonEmpty alg a
left' CSMT 'NonEmpty alg a
right
      Ordering
GT -> Digest alg
-> CSMT 'NonEmpty alg a
-> (forall (j :: Size). CSMT j alg a -> b)
-> b
forall alg (i :: Size) a b.
HashAlgorithm alg =>
Digest alg
-> CSMT i alg a -> (forall (j :: Size). CSMT j alg a -> b) -> b
deleteDigest Digest alg
h CSMT 'NonEmpty alg a
right ((forall (j :: Size). CSMT j alg a -> b) -> b)
-> (forall (j :: Size). CSMT j alg a -> b) -> b
forall a b. (a -> b) -> a -> b
$ \case
        Nil {} -> CSMT 'NonEmpty alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree CSMT 'NonEmpty alg a
left
        right' :: CSMT j alg a
right'@Leaf {} -> CSMT 'NonEmpty alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree (CSMT 'NonEmpty alg a -> b) -> CSMT 'NonEmpty alg a -> b
forall a b. (a -> b) -> a -> b
$ CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT 'NonEmpty alg a
left CSMT j alg a
CSMT 'NonEmpty alg a
right'
        right' :: CSMT j alg a
right'@Parent {} -> CSMT 'NonEmpty alg a -> b
forall (j :: Size). CSMT j alg a -> b
returnTree (CSMT 'NonEmpty alg a -> b) -> CSMT 'NonEmpty alg a -> b
forall a b. (a -> b) -> a -> b
$ CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall alg a.
HashAlgorithm alg =>
CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT 'NonEmpty alg a
left CSMT j alg a
CSMT 'NonEmpty alg a
right'

compareSubTrees :: Digest alg -> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
compareSubTrees :: Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
compareSubTrees Digest alg
h = (CSMT 'NonEmpty alg a -> Int)
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Digest alg -> Digest alg -> Int
forall alg. Digest alg -> Digest alg -> Int
distance Digest alg
h (Digest alg -> Int)
-> (CSMT 'NonEmpty alg a -> Digest alg)
-> CSMT 'NonEmpty alg a
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest)

distance :: Digest alg -> Digest alg -> Int
distance :: Digest alg -> Digest alg -> Int
distance Digest alg
a = ByteString -> Int
logBase2 (ByteString -> Int)
-> (Digest alg -> ByteString) -> Digest alg -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest alg -> Digest alg -> ByteString
forall a b c.
(ByteArrayAccess a, ByteArrayAccess b, ByteArray c) =>
a -> b -> c
BA.xor Digest alg
a
  where
    logBase2 :: ByteString -> Int
logBase2 ByteString
x =
      Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* ByteString -> Int
BS.length ByteString
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- case (Word8 -> Bool) -> [Word8] -> ([Word8], [Word8])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) (ByteString -> [Word8]
BS.unpack ByteString
x) of
        ([Word8]
zeros, [Word8]
nonZeros) ->
          Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
zeros Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case [Word8]
nonZeros of
            [] -> Int
0
            (Word8
w : [Word8]
_) -> Word8 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros Word8
w

-- | The maximum digest in the tree.
--
-- Worst case Θ(1).
maximumDigest :: CSMT 'NonEmpty alg a -> Digest alg
maximumDigest :: CSMT 'NonEmpty alg a -> Digest alg
maximumDigest Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest} = Digest alg
digest
maximumDigest Parent {Digest alg
maxDigest :: Digest alg
$sel:maxDigest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maxDigest} = Digest alg
maxDigest

-- | The minimum digest in the tree.
--
-- Average case Θ(log n), Worst case Θ(n) where n is the size of the tree.
minimumDigest :: CSMT 'NonEmpty alg a -> Digest alg
minimumDigest :: CSMT 'NonEmpty alg a -> Digest alg
minimumDigest = \case
  Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest} -> Digest alg
digest
  Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left} -> CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
minimumDigest CSMT 'NonEmpty alg a
left

parent :: HashAlgorithm alg => CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent :: CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
parent CSMT 'NonEmpty alg a
left CSMT 'NonEmpty alg a
right =
  Parent :: forall alg a.
CSMT 'NonEmpty alg a
-> Digest alg
-> Digest alg
-> CSMT 'NonEmpty alg a
-> CSMT 'NonEmpty alg a
Parent
    { CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: CSMT 'NonEmpty alg a
left,
      $sel:digest:Nil :: Digest alg
digest = Digest alg -> Digest alg -> Digest alg
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> ba -> Digest a
hashParent (CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest CSMT 'NonEmpty alg a
left) (CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest CSMT 'NonEmpty alg a
right),
      $sel:maxDigest:Nil :: Digest alg
maxDigest = Digest alg -> Digest alg -> Digest alg
forall a. Ord a => a -> a -> a
max (CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest CSMT 'NonEmpty alg a
left) (CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest CSMT 'NonEmpty alg a
right),
      CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: CSMT 'NonEmpty alg a
right
    }

hashLeaf :: (HashAlgorithm a, ByteArrayAccess ba) => ba -> Digest a
hashLeaf :: ba -> Digest a
hashLeaf = Context a -> Digest a
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize (Context a -> Digest a) -> (ba -> Context a) -> ba -> Digest a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context a -> ba -> Context a
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (Context a -> ByteString -> Context a
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate Context a
forall a. HashAlgorithm a => Context a
hashInit (Word8 -> ByteString
BS.singleton Word8
0))

hashParent :: (HashAlgorithm a, ByteArrayAccess ba) => ba -> ba -> Digest a
hashParent :: ba -> ba -> Digest a
hashParent ba
x ba
y = Context a -> Digest a
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize (Context a -> Digest a) -> Context a -> Digest a
forall a b. (a -> b) -> a -> b
$ Context a -> [ba] -> Context a
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates (Context a -> ByteString -> Context a
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate Context a
forall a. HashAlgorithm a => Context a
hashInit (Word8 -> ByteString
BS.singleton Word8
1)) [ba
x, ba
y]

--------------------------------------------------------------------------------

-- | A membership proof over a hash algorithm @alg@.
data MembershipProof alg = forall p. MembershipProof (Proof Direction p alg)

-- | A proof of @p@ with direction @d@ over a hash algorithm @alg@.
data Proof d (p :: ProofType) alg where
  -- | A proof of inclusion.
  InclusionProof ::
    { -- | A digest of an included element.
      Proof d 'Inclusion alg -> Digest alg
includedDigest :: Digest alg,
      -- | A list of sibling digests from the root to the included element with the directions from their parents.
      Proof d 'Inclusion alg -> [(Digest alg, d)]
rootPath :: [(Digest alg, d)]
    } ->
    Proof d 'Inclusion alg
  -- | A proof of exclusion.
  ExclusionProof ::
    { -- | The digest of an excluded element.
      Proof d 'Exclusion alg -> Digest alg
excludedDigest :: Digest alg,
      -- | A uni-directional inclusion proof from the left of the immediate predecessor to the included element, if one exists.
      Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediatePredecessor :: Maybe (Proof () 'Inclusion alg),
      -- | A uni-directional inclusion proof from the right of the immediate successor to the included element, if one exists.
      Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediateSuccessor :: Maybe (Proof () 'Inclusion alg),
      -- | A list of sibling digests from the root to the first common sibling of the immediate predecessor and successors with the directions from their parents.
      Proof d 'Exclusion alg -> [(Digest alg, d)]
commonRootPath :: [(Digest alg, d)]
    } ->
    Proof d 'Exclusion alg

deriving instance Show d => Show (Proof d alg p)

-- | A direction of a node from its parent.
data Direction
  = -- | A left node
    L
  | -- | A right node
    R
  deriving (Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show, Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq)

deriving instance Show (MembershipProof alg)

-- | A type of proof
data ProofType
  = -- | A proof that an element is in a tree.
    Inclusion
  | -- | A proof that an element is not in a tree.
    Exclusion

-- | Is the element in the tree?
--
-- Average case Θ(log n), Worst case Θ(n) where n is the size of the tree.
member :: (ByteArrayAccess a, HashAlgorithm alg) => a -> CSMT i alg a -> Bool
member :: a -> CSMT i alg a -> Bool
member a
x = MembershipProof alg -> Bool
forall alg. MembershipProof alg -> Bool
isInclusionProof (MembershipProof alg -> Bool)
-> (CSMT i alg a -> MembershipProof alg) -> CSMT i alg a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> CSMT i alg a -> MembershipProof alg
forall a alg (i :: Size).
(ByteArrayAccess a, HashAlgorithm alg) =>
a -> CSMT i alg a -> MembershipProof alg
membershipProof a
x

-- | Is the element not in the tree?
--
-- Average case Θ(log n), Worst case Θ(n) where n is the size of the tree.
notMember :: (ByteArrayAccess a, HashAlgorithm alg) => a -> CSMT i alg a -> Bool
notMember :: a -> CSMT i alg a -> Bool
notMember a
x = Bool -> Bool
not (Bool -> Bool) -> (CSMT i alg a -> Bool) -> CSMT i alg a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> CSMT i alg a -> Bool
forall a alg (i :: Size).
(ByteArrayAccess a, HashAlgorithm alg) =>
a -> CSMT i alg a -> Bool
member a
x

-- | Lookup the value with the digest in the map.
--
-- Average case Θ(log n), Worst case Θ(n) where n is the size of the tree.
lookup :: Digest alg -> CSMT i alg a -> Maybe a
lookup :: Digest alg -> CSMT i alg a -> Maybe a
lookup Digest alg
h = \case
  Nil {} -> Maybe a
forall a. Maybe a
Nothing
  Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest, a
value :: a
$sel:value:Nil :: forall alg a. CSMT 'NonEmpty alg a -> a
value}
    | Digest alg
h Digest alg -> Digest alg -> Bool
forall a. Eq a => a -> a -> Bool
== Digest alg
digest -> a -> Maybe a
forall a. a -> Maybe a
Just a
value
    | Bool
otherwise -> Maybe a
forall a. Maybe a
Nothing
  Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left, CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right} ->
    case Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
forall alg a.
Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
compareSubTrees Digest alg
h CSMT 'NonEmpty alg a
left CSMT 'NonEmpty alg a
right of
      Ordering
EQ -> Maybe a
forall a. Maybe a
Nothing
      Ordering
LT -> Digest alg -> CSMT 'NonEmpty alg a -> Maybe a
forall alg (i :: Size) a. Digest alg -> CSMT i alg a -> Maybe a
lookup Digest alg
h CSMT 'NonEmpty alg a
left
      Ordering
GT -> Digest alg -> CSMT 'NonEmpty alg a -> Maybe a
forall alg (i :: Size) a. Digest alg -> CSMT i alg a -> Maybe a
lookup Digest alg
h CSMT 'NonEmpty alg a
right

-- | Is this an inclusion proof?
--
-- Worst case Θ(1).
isInclusionProof :: MembershipProof alg -> Bool
isInclusionProof :: MembershipProof alg -> Bool
isInclusionProof = \case
  MembershipProof (InclusionProof {}) -> Bool
True
  MembershipProof alg
_ -> Bool
False

-- | Is this an exclusion proof?
--
-- Worst case Θ(1).
isExclusionProof :: MembershipProof alg -> Bool
isExclusionProof :: MembershipProof alg -> Bool
isExclusionProof = Bool -> Bool
not (Bool -> Bool)
-> (MembershipProof alg -> Bool) -> MembershipProof alg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MembershipProof alg -> Bool
forall alg. MembershipProof alg -> Bool
isInclusionProof

-- | Construct a membership proof of inclusion if the given element is in the
-- tree, or a proof of exclusion if the element is not in the tree.
--
-- Average case Θ(log n), Worst case Θ(n) where n is the size of the tree.
-- The constructed membership proof has equivalent space complexity.
membershipProof :: (ByteArrayAccess a, HashAlgorithm alg) => a -> CSMT i alg a -> MembershipProof alg
membershipProof :: a -> CSMT i alg a -> MembershipProof alg
membershipProof a
x = [(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT i alg a -> MembershipProof alg
forall alg a (i :: Size).
[(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT i alg a -> MembershipProof alg
membershipProofDigest [] (a -> Digest alg
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Digest a
hashLeaf a
x)

membershipProofDigest :: [(CSMT 'NonEmpty alg a, Direction)] -> Digest alg -> CSMT i alg a -> MembershipProof alg
membershipProofDigest :: [(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT i alg a -> MembershipProof alg
membershipProofDigest [(CSMT 'NonEmpty alg a, Direction)]
path Digest alg
h = \case
  Nil {} ->
    Proof Direction 'Exclusion alg -> MembershipProof alg
forall alg (p :: ProofType).
Proof Direction p alg -> MembershipProof alg
MembershipProof (Proof Direction 'Exclusion alg -> MembershipProof alg)
-> Proof Direction 'Exclusion alg -> MembershipProof alg
forall a b. (a -> b) -> a -> b
$ Digest alg -> Proof Direction 'Exclusion alg
forall alg d. Digest alg -> Proof d 'Exclusion alg
trivialExclusionProof Digest alg
h
  leaf :: CSMT i alg a
leaf@Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest} -> case Digest alg
h Digest alg -> Digest alg -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Digest alg
digest of
    Ordering
EQ ->
      Proof Direction 'Inclusion alg -> MembershipProof alg
forall alg (p :: ProofType).
Proof Direction p alg -> MembershipProof alg
MembershipProof (Digest alg -> Proof Any 'Inclusion alg
forall alg d. Digest alg -> Proof d 'Inclusion alg
trivialInclusionProof Digest alg
digest) {$sel:rootPath:InclusionProof :: [(Digest alg, Direction)]
rootPath = [(CSMT 'NonEmpty alg a, Direction)] -> [(Digest alg, Direction)]
forall alg a d. [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)]
toRootPath [(CSMT 'NonEmpty alg a, Direction)]
path}
    Ordering
__ -> [(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
forall alg a.
[(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
nonMembershipProof [(CSMT 'NonEmpty alg a, Direction)]
path Digest alg
h CSMT i alg a
CSMT 'NonEmpty alg a
leaf
  root :: CSMT i alg a
root@Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left, CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right} ->
    case Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
forall alg a.
Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
compareSubTrees Digest alg
h CSMT 'NonEmpty alg a
left CSMT 'NonEmpty alg a
right of
      Ordering
EQ -> case Digest alg
h Digest alg -> Digest alg -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest CSMT i alg a
CSMT 'NonEmpty alg a
root of
        Ordering
LT -> [(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
forall alg a.
[(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
nonMembershipProof ((CSMT 'NonEmpty alg a
right, Direction
R) (CSMT 'NonEmpty alg a, Direction)
-> [(CSMT 'NonEmpty alg a, Direction)]
-> [(CSMT 'NonEmpty alg a, Direction)]
forall a. a -> [a] -> [a]
: [(CSMT 'NonEmpty alg a, Direction)]
path) Digest alg
h CSMT 'NonEmpty alg a
left
        Ordering
__ -> [(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
forall alg a.
[(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
nonMembershipProof ((CSMT 'NonEmpty alg a
left, Direction
L) (CSMT 'NonEmpty alg a, Direction)
-> [(CSMT 'NonEmpty alg a, Direction)]
-> [(CSMT 'NonEmpty alg a, Direction)]
forall a. a -> [a] -> [a]
: [(CSMT 'NonEmpty alg a, Direction)]
path) Digest alg
h CSMT 'NonEmpty alg a
right
      Ordering
LT -> [(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
forall alg a (i :: Size).
[(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT i alg a -> MembershipProof alg
membershipProofDigest ((CSMT 'NonEmpty alg a
right, Direction
R) (CSMT 'NonEmpty alg a, Direction)
-> [(CSMT 'NonEmpty alg a, Direction)]
-> [(CSMT 'NonEmpty alg a, Direction)]
forall a. a -> [a] -> [a]
: [(CSMT 'NonEmpty alg a, Direction)]
path) Digest alg
h CSMT 'NonEmpty alg a
left
      Ordering
GT -> [(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
forall alg a (i :: Size).
[(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT i alg a -> MembershipProof alg
membershipProofDigest ((CSMT 'NonEmpty alg a
left, Direction
L) (CSMT 'NonEmpty alg a, Direction)
-> [(CSMT 'NonEmpty alg a, Direction)]
-> [(CSMT 'NonEmpty alg a, Direction)]
forall a. a -> [a] -> [a]
: [(CSMT 'NonEmpty alg a, Direction)]
path) Digest alg
h CSMT 'NonEmpty alg a
right

nonMembershipProof :: [(CSMT 'NonEmpty alg a, Direction)] -> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
nonMembershipProof :: [(CSMT 'NonEmpty alg a, Direction)]
-> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg
nonMembershipProof [(CSMT 'NonEmpty alg a, Direction)]
path Digest alg
h CSMT 'NonEmpty alg a
t =
  let exclusionProof :: Proof Direction 'Exclusion alg
exclusionProof = Digest alg -> Proof Direction 'Exclusion alg
forall alg d. Digest alg -> Proof d 'Exclusion alg
trivialExclusionProof Digest alg
h
   in case Digest alg
h Digest alg -> Digest alg -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest CSMT 'NonEmpty alg a
t of
        Ordering
LT ->
          case Direction
-> [(CSMT 'NonEmpty alg a, Direction)]
-> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, Direction)])
forall d alg a.
Eq d =>
d
-> [(CSMT 'NonEmpty alg a, d)]
-> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, d)])
spanDirection Direction
R [(CSMT 'NonEmpty alg a, Direction)]
path of
            ([(Digest alg, ())]
successorPath, []) ->
              Proof Direction 'Exclusion alg -> MembershipProof alg
forall alg (p :: ProofType).
Proof Direction p alg -> MembershipProof alg
MembershipProof (Proof Direction 'Exclusion alg -> MembershipProof alg)
-> Proof Direction 'Exclusion alg -> MembershipProof alg
forall a b. (a -> b) -> a -> b
$
                Proof Direction 'Exclusion alg
exclusionProof
                  { $sel:immediateSuccessor:InclusionProof :: Maybe (Proof () 'Inclusion alg)
immediateSuccessor = Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a. a -> Maybe a
Just (Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg))
-> Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a b. (a -> b) -> a -> b
$ [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a.
[(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
minimumDigestInclusionProof' [(Digest alg, ())]
successorPath CSMT 'NonEmpty alg a
t
                  }
            ([(Digest alg, ())]
successorPath, (CSMT 'NonEmpty alg a
sibling, Direction
_) : [(CSMT 'NonEmpty alg a, Direction)]
commonPath) ->
              Proof Direction 'Exclusion alg -> MembershipProof alg
forall alg (p :: ProofType).
Proof Direction p alg -> MembershipProof alg
MembershipProof (Proof Direction 'Exclusion alg -> MembershipProof alg)
-> Proof Direction 'Exclusion alg -> MembershipProof alg
forall a b. (a -> b) -> a -> b
$
                Proof Direction 'Exclusion alg
exclusionProof
                  { $sel:immediateSuccessor:InclusionProof :: Maybe (Proof () 'Inclusion alg)
immediateSuccessor = Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a. a -> Maybe a
Just (Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg))
-> Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a b. (a -> b) -> a -> b
$ [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a.
[(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
minimumDigestInclusionProof' [(Digest alg, ())]
successorPath CSMT 'NonEmpty alg a
t,
                    $sel:immediatePredecessor:InclusionProof :: Maybe (Proof () 'Inclusion alg)
immediatePredecessor = Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a. a -> Maybe a
Just (Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg))
-> Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a b. (a -> b) -> a -> b
$ CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a. CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
maximumDigestInclusionProof CSMT 'NonEmpty alg a
sibling,
                    $sel:commonRootPath:InclusionProof :: [(Digest alg, Direction)]
commonRootPath = [(CSMT 'NonEmpty alg a, Direction)] -> [(Digest alg, Direction)]
forall alg a d. [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)]
toRootPath [(CSMT 'NonEmpty alg a, Direction)]
commonPath
                  }
        Ordering
__ ->
          case Direction
-> [(CSMT 'NonEmpty alg a, Direction)]
-> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, Direction)])
forall d alg a.
Eq d =>
d
-> [(CSMT 'NonEmpty alg a, d)]
-> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, d)])
spanDirection Direction
L [(CSMT 'NonEmpty alg a, Direction)]
path of
            ([(Digest alg, ())]
predecessorPath, []) ->
              Proof Direction 'Exclusion alg -> MembershipProof alg
forall alg (p :: ProofType).
Proof Direction p alg -> MembershipProof alg
MembershipProof (Proof Direction 'Exclusion alg -> MembershipProof alg)
-> Proof Direction 'Exclusion alg -> MembershipProof alg
forall a b. (a -> b) -> a -> b
$
                Proof Direction 'Exclusion alg
exclusionProof
                  { $sel:immediatePredecessor:InclusionProof :: Maybe (Proof () 'Inclusion alg)
immediatePredecessor = Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a. a -> Maybe a
Just (Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg))
-> Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a b. (a -> b) -> a -> b
$ [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a.
[(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
maximumDigestInclusionProof' [(Digest alg, ())]
predecessorPath CSMT 'NonEmpty alg a
t
                  }
            ([(Digest alg, ())]
predecessorPath, (CSMT 'NonEmpty alg a
sibling, Direction
_) : [(CSMT 'NonEmpty alg a, Direction)]
commonPath) ->
              Proof Direction 'Exclusion alg -> MembershipProof alg
forall alg (p :: ProofType).
Proof Direction p alg -> MembershipProof alg
MembershipProof (Proof Direction 'Exclusion alg -> MembershipProof alg)
-> Proof Direction 'Exclusion alg -> MembershipProof alg
forall a b. (a -> b) -> a -> b
$
                Proof Direction 'Exclusion alg
exclusionProof
                  { $sel:immediatePredecessor:InclusionProof :: Maybe (Proof () 'Inclusion alg)
immediatePredecessor = Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a. a -> Maybe a
Just (Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg))
-> Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a b. (a -> b) -> a -> b
$ [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a.
[(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
maximumDigestInclusionProof' [(Digest alg, ())]
predecessorPath CSMT 'NonEmpty alg a
t,
                    $sel:immediateSuccessor:InclusionProof :: Maybe (Proof () 'Inclusion alg)
immediateSuccessor = Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a. a -> Maybe a
Just (Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg))
-> Proof () 'Inclusion alg -> Maybe (Proof () 'Inclusion alg)
forall a b. (a -> b) -> a -> b
$ CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a. CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
minimumDigestInclusionProof CSMT 'NonEmpty alg a
sibling,
                    $sel:commonRootPath:InclusionProof :: [(Digest alg, Direction)]
commonRootPath = [(CSMT 'NonEmpty alg a, Direction)] -> [(Digest alg, Direction)]
forall alg a d. [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)]
toRootPath [(CSMT 'NonEmpty alg a, Direction)]
commonPath
                  }

spanDirection :: Eq d => d -> [(CSMT 'NonEmpty alg a, d)] -> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, d)])
spanDirection :: d
-> [(CSMT 'NonEmpty alg a, d)]
-> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, d)])
spanDirection d
d = ([(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, ())])
-> ([(CSMT 'NonEmpty alg a, d)], [(CSMT 'NonEmpty alg a, d)])
-> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, d)])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, ())]
forall alg a d. [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, ())]
toUniRootPath (([(CSMT 'NonEmpty alg a, d)], [(CSMT 'NonEmpty alg a, d)])
 -> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, d)]))
-> ([(CSMT 'NonEmpty alg a, d)]
    -> ([(CSMT 'NonEmpty alg a, d)], [(CSMT 'NonEmpty alg a, d)]))
-> [(CSMT 'NonEmpty alg a, d)]
-> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, d)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CSMT 'NonEmpty alg a, d) -> Bool)
-> [(CSMT 'NonEmpty alg a, d)]
-> ([(CSMT 'NonEmpty alg a, d)], [(CSMT 'NonEmpty alg a, d)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((d
d d -> d -> Bool
forall a. Eq a => a -> a -> Bool
==) (d -> Bool)
-> ((CSMT 'NonEmpty alg a, d) -> d)
-> (CSMT 'NonEmpty alg a, d)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CSMT 'NonEmpty alg a, d) -> d
forall a b. (a, b) -> b
snd)

toUniRootPath :: [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, ())]
toUniRootPath :: [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, ())]
toUniRootPath = ((Digest alg, d) -> (Digest alg, ()))
-> [(Digest alg, d)] -> [(Digest alg, ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Digest alg, d) -> (Digest alg, ())
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([(Digest alg, d)] -> [(Digest alg, ())])
-> ([(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)])
-> [(CSMT 'NonEmpty alg a, d)]
-> [(Digest alg, ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)]
forall alg a d. [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)]
toRootPath

toRootPath :: [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)]
toRootPath :: [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)]
toRootPath = ((CSMT 'NonEmpty alg a, d) -> (Digest alg, d))
-> [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CSMT 'NonEmpty alg a -> Digest alg)
-> (CSMT 'NonEmpty alg a, d) -> (Digest alg, d)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest)

trivialInclusionProof :: Digest alg -> Proof d 'Inclusion alg
trivialInclusionProof :: Digest alg -> Proof d 'Inclusion alg
trivialInclusionProof Digest alg
h =
  InclusionProof :: forall alg d.
Digest alg -> [(Digest alg, d)] -> Proof d 'Inclusion alg
InclusionProof
    { $sel:includedDigest:InclusionProof :: Digest alg
includedDigest = Digest alg
h,
      $sel:rootPath:InclusionProof :: [(Digest alg, d)]
rootPath = [(Digest alg, d)]
forall a. Monoid a => a
mempty
    }

trivialExclusionProof :: Digest alg -> Proof d 'Exclusion alg
trivialExclusionProof :: Digest alg -> Proof d 'Exclusion alg
trivialExclusionProof Digest alg
h =
  ExclusionProof :: forall alg d.
Digest alg
-> Maybe (Proof () 'Inclusion alg)
-> Maybe (Proof () 'Inclusion alg)
-> [(Digest alg, d)]
-> Proof d 'Exclusion alg
ExclusionProof
    { $sel:excludedDigest:InclusionProof :: Digest alg
excludedDigest = Digest alg
h,
      $sel:commonRootPath:InclusionProof :: [(Digest alg, d)]
commonRootPath = [],
      $sel:immediatePredecessor:InclusionProof :: Maybe (Proof () 'Inclusion alg)
immediatePredecessor = Maybe (Proof () 'Inclusion alg)
forall a. Maybe a
Nothing,
      $sel:immediateSuccessor:InclusionProof :: Maybe (Proof () 'Inclusion alg)
immediateSuccessor = Maybe (Proof () 'Inclusion alg)
forall a. Maybe a
Nothing
    }

maximumDigestInclusionProof :: CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
maximumDigestInclusionProof :: CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
maximumDigestInclusionProof = [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a.
[(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
maximumDigestInclusionProof' []

maximumDigestInclusionProof' :: [(Digest alg, ())] -> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
maximumDigestInclusionProof' :: [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
maximumDigestInclusionProof' [(Digest alg, ())]
path = \case
  Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest} -> (Digest alg -> Proof Any 'Inclusion alg
forall alg d. Digest alg -> Proof d 'Inclusion alg
trivialInclusionProof Digest alg
digest) {$sel:rootPath:InclusionProof :: [(Digest alg, ())]
rootPath = [(Digest alg, ())]
path}
  Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left, CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right} -> [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a.
[(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
maximumDigestInclusionProof' ((CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest CSMT 'NonEmpty alg a
left, ()) (Digest alg, ()) -> [(Digest alg, ())] -> [(Digest alg, ())]
forall a. a -> [a] -> [a]
: [(Digest alg, ())]
path) CSMT 'NonEmpty alg a
right

minimumDigestInclusionProof :: CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
minimumDigestInclusionProof :: CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
minimumDigestInclusionProof = [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a.
[(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
minimumDigestInclusionProof' []

minimumDigestInclusionProof' :: [(Digest alg, ())] -> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
minimumDigestInclusionProof' :: [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
minimumDigestInclusionProof' [(Digest alg, ())]
path = \case
  Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest} -> (Digest alg -> Proof Any 'Inclusion alg
forall alg d. Digest alg -> Proof d 'Inclusion alg
trivialInclusionProof Digest alg
digest) {$sel:rootPath:InclusionProof :: [(Digest alg, ())]
rootPath = [(Digest alg, ())]
path}
  Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left, CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right} -> [(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
forall alg a.
[(Digest alg, ())]
-> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg
minimumDigestInclusionProof' ((CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest CSMT 'NonEmpty alg a
right, ()) (Digest alg, ()) -> [(Digest alg, ())] -> [(Digest alg, ())]
forall a. a -> [a] -> [a]
: [(Digest alg, ())]
path) CSMT 'NonEmpty alg a
left

--------------------------------------------------------------------------------

-- | A merkle root of a tree.
data MerkleRoot alg
  = -- | A merkle root of an empty tree.
    EmptyMerkleRoot
  | -- | A merkle root of a non-empty tree.
    MerkleRoot (Digest alg)
  deriving (Int -> MerkleRoot alg -> ShowS
[MerkleRoot alg] -> ShowS
MerkleRoot alg -> String
(Int -> MerkleRoot alg -> ShowS)
-> (MerkleRoot alg -> String)
-> ([MerkleRoot alg] -> ShowS)
-> Show (MerkleRoot alg)
forall alg. Int -> MerkleRoot alg -> ShowS
forall alg. [MerkleRoot alg] -> ShowS
forall alg. MerkleRoot alg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MerkleRoot alg] -> ShowS
$cshowList :: forall alg. [MerkleRoot alg] -> ShowS
show :: MerkleRoot alg -> String
$cshow :: forall alg. MerkleRoot alg -> String
showsPrec :: Int -> MerkleRoot alg -> ShowS
$cshowsPrec :: forall alg. Int -> MerkleRoot alg -> ShowS
Show, MerkleRoot alg -> MerkleRoot alg -> Bool
(MerkleRoot alg -> MerkleRoot alg -> Bool)
-> (MerkleRoot alg -> MerkleRoot alg -> Bool)
-> Eq (MerkleRoot alg)
forall alg. MerkleRoot alg -> MerkleRoot alg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleRoot alg -> MerkleRoot alg -> Bool
$c/= :: forall alg. MerkleRoot alg -> MerkleRoot alg -> Bool
== :: MerkleRoot alg -> MerkleRoot alg -> Bool
$c== :: forall alg. MerkleRoot alg -> MerkleRoot alg -> Bool
Eq)

-- | The merkle root of a tree.
--
-- Worst case Θ(1).
merkleRoot :: CSMT i alg a -> MerkleRoot alg
merkleRoot :: CSMT i alg a -> MerkleRoot alg
merkleRoot = \case
  Nil {} -> MerkleRoot alg
forall alg. MerkleRoot alg
EmptyMerkleRoot
  Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest} -> Digest alg -> MerkleRoot alg
forall alg. Digest alg -> MerkleRoot alg
MerkleRoot Digest alg
digest
  Parent {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest} -> Digest alg -> MerkleRoot alg
forall alg. Digest alg -> MerkleRoot alg
MerkleRoot Digest alg
digest

-- | Validate a membership proof against a merkle root.
--
-- Worst case Θ(d) where d is the number of hash digests in the membership proof.
validProof :: HashAlgorithm alg => MerkleRoot alg -> MembershipProof alg -> Bool
validProof :: MerkleRoot alg -> MembershipProof alg -> Bool
validProof MerkleRoot alg
root = \case
  MembershipProof proof :: Proof Direction p alg
proof@InclusionProof {} -> MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
forall alg.
HashAlgorithm alg =>
MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
validInclusionProof MerkleRoot alg
root Proof Direction p alg
Proof Direction 'Inclusion alg
proof
  MembershipProof proof :: Proof Direction p alg
proof@ExclusionProof {} -> MerkleRoot alg -> Proof Direction 'Exclusion alg -> Bool
forall alg.
HashAlgorithm alg =>
MerkleRoot alg -> Proof Direction 'Exclusion alg -> Bool
validExclusionProof MerkleRoot alg
root Proof Direction p alg
Proof Direction 'Exclusion alg
proof

-- | Validate an inclusion proof against a merkle root.
--
-- Worst case Θ(d) where d is the number of hash digests in the inclusion proof.
validInclusionProof :: HashAlgorithm alg => MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
validInclusionProof :: MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
validInclusionProof MerkleRoot alg
EmptyMerkleRoot Proof Direction 'Inclusion alg
_ = Bool
False
validInclusionProof (MerkleRoot Digest alg
root) Proof Direction 'Inclusion alg
proof = Digest alg
root Digest alg -> Digest alg -> Bool
forall a. Eq a => a -> a -> Bool
== Proof Direction 'Inclusion alg -> Digest alg
forall alg.
HashAlgorithm alg =>
Proof Direction 'Inclusion alg -> Digest alg
inclusionProofMerkleRoot Proof Direction 'Inclusion alg
proof

inclusionProofMerkleRoot :: HashAlgorithm alg => Proof Direction 'Inclusion alg -> Digest alg
inclusionProofMerkleRoot :: Proof Direction 'Inclusion alg -> Digest alg
inclusionProofMerkleRoot InclusionProof {Digest alg
includedDigest :: Digest alg
$sel:includedDigest:InclusionProof :: forall d alg. Proof d 'Inclusion alg -> Digest alg
includedDigest, [(Digest alg, Direction)]
rootPath :: [(Digest alg, Direction)]
$sel:rootPath:InclusionProof :: forall d alg. Proof d 'Inclusion alg -> [(Digest alg, d)]
rootPath} =
  (Digest alg -> (Digest alg, Direction) -> Digest alg)
-> Digest alg -> [(Digest alg, Direction)] -> Digest alg
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    ( \Digest alg
result (Digest alg
siblingDigest, Direction
direction) -> (Digest alg -> Digest alg -> Digest alg)
-> (Digest alg, Digest alg) -> Digest alg
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Digest alg -> Digest alg -> Digest alg
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> ba -> Digest a
hashParent ((Digest alg, Digest alg) -> Digest alg)
-> (Digest alg, Digest alg) -> Digest alg
forall a b. (a -> b) -> a -> b
$
        case Direction
direction of
          Direction
L -> (Digest alg
siblingDigest, Digest alg
result)
          Direction
R -> (Digest alg
result, Digest alg
siblingDigest)
    )
    Digest alg
includedDigest
    [(Digest alg, Direction)]
rootPath

-- | Validate an exclusion proof against a merkle root.
--
-- Worst case Θ(d) where d is the number of hash digests in the exclusion proof.
validExclusionProof :: HashAlgorithm alg => MerkleRoot alg -> Proof Direction 'Exclusion alg -> Bool
validExclusionProof :: MerkleRoot alg -> Proof Direction 'Exclusion alg -> Bool
validExclusionProof MerkleRoot alg
root = \case
  ExclusionProof {$sel:immediatePredecessor:InclusionProof :: forall d alg.
Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediatePredecessor = Maybe (Proof () 'Inclusion alg)
Nothing, $sel:immediateSuccessor:InclusionProof :: forall d alg.
Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediateSuccessor = Maybe (Proof () 'Inclusion alg)
Nothing} ->
    MerkleRoot alg
root MerkleRoot alg -> MerkleRoot alg -> Bool
forall a. Eq a => a -> a -> Bool
== MerkleRoot alg
forall alg. MerkleRoot alg
EmptyMerkleRoot
  ExclusionProof {$sel:immediatePredecessor:InclusionProof :: forall d alg.
Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediatePredecessor = Just Proof () 'Inclusion alg
p, Digest alg
excludedDigest :: Digest alg
$sel:excludedDigest:InclusionProof :: forall d alg. Proof d 'Exclusion alg -> Digest alg
excludedDigest, $sel:immediateSuccessor:InclusionProof :: forall d alg.
Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediateSuccessor = Maybe (Proof () 'Inclusion alg)
Nothing}
    | Proof () 'Inclusion alg -> Digest alg
forall d alg. Proof d 'Inclusion alg -> Digest alg
includedDigest Proof () 'Inclusion alg
p Digest alg -> Digest alg -> Bool
forall a. Ord a => a -> a -> Bool
< Digest alg
excludedDigest ->
      MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
forall alg.
HashAlgorithm alg =>
MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
validInclusionProof MerkleRoot alg
root (Proof Direction 'Inclusion alg -> Bool)
-> Proof Direction 'Inclusion alg -> Bool
forall a b. (a -> b) -> a -> b
$ (() -> Direction)
-> Proof () 'Inclusion alg -> Proof Direction 'Inclusion alg
forall d d' alg.
(d -> d') -> Proof d 'Inclusion alg -> Proof d' 'Inclusion alg
mapProofDirection (Direction -> () -> Direction
forall a b. a -> b -> a
const Direction
L) Proof () 'Inclusion alg
p
  ExclusionProof {$sel:immediatePredecessor:InclusionProof :: forall d alg.
Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediatePredecessor = Maybe (Proof () 'Inclusion alg)
Nothing, Digest alg
excludedDigest :: Digest alg
$sel:excludedDigest:InclusionProof :: forall d alg. Proof d 'Exclusion alg -> Digest alg
excludedDigest, $sel:immediateSuccessor:InclusionProof :: forall d alg.
Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediateSuccessor = Just Proof () 'Inclusion alg
q}
    | Digest alg
excludedDigest Digest alg -> Digest alg -> Bool
forall a. Ord a => a -> a -> Bool
< Proof () 'Inclusion alg -> Digest alg
forall d alg. Proof d 'Inclusion alg -> Digest alg
includedDigest Proof () 'Inclusion alg
q ->
      MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
forall alg.
HashAlgorithm alg =>
MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
validInclusionProof MerkleRoot alg
root (Proof Direction 'Inclusion alg -> Bool)
-> Proof Direction 'Inclusion alg -> Bool
forall a b. (a -> b) -> a -> b
$ (() -> Direction)
-> Proof () 'Inclusion alg -> Proof Direction 'Inclusion alg
forall d d' alg.
(d -> d') -> Proof d 'Inclusion alg -> Proof d' 'Inclusion alg
mapProofDirection (Direction -> () -> Direction
forall a b. a -> b -> a
const Direction
R) Proof () 'Inclusion alg
q
  ExclusionProof {$sel:immediatePredecessor:InclusionProof :: forall d alg.
Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediatePredecessor = Just Proof () 'Inclusion alg
p, [(Digest alg, Direction)]
commonRootPath :: [(Digest alg, Direction)]
$sel:commonRootPath:InclusionProof :: forall d alg. Proof d 'Exclusion alg -> [(Digest alg, d)]
commonRootPath, Digest alg
excludedDigest :: Digest alg
$sel:excludedDigest:InclusionProof :: forall d alg. Proof d 'Exclusion alg -> Digest alg
excludedDigest, $sel:immediateSuccessor:InclusionProof :: forall d alg.
Proof d 'Exclusion alg -> Maybe (Proof () 'Inclusion alg)
immediateSuccessor = Just Proof () 'Inclusion alg
q}
    | Proof () 'Inclusion alg -> Digest alg
forall d alg. Proof d 'Inclusion alg -> Digest alg
includedDigest Proof () 'Inclusion alg
p Digest alg -> Digest alg -> Bool
forall a. Ord a => a -> a -> Bool
< Digest alg
excludedDigest,
      Digest alg
excludedDigest Digest alg -> Digest alg -> Bool
forall a. Ord a => a -> a -> Bool
< Proof () 'Inclusion alg -> Digest alg
forall d alg. Proof d 'Inclusion alg -> Digest alg
includedDigest Proof () 'Inclusion alg
q ->
      let leftMerkleRoot :: Digest alg
leftMerkleRoot = Proof Direction 'Inclusion alg -> Digest alg
forall alg.
HashAlgorithm alg =>
Proof Direction 'Inclusion alg -> Digest alg
inclusionProofMerkleRoot (Proof Direction 'Inclusion alg -> Digest alg)
-> Proof Direction 'Inclusion alg -> Digest alg
forall a b. (a -> b) -> a -> b
$ (() -> Direction)
-> Proof () 'Inclusion alg -> Proof Direction 'Inclusion alg
forall d d' alg.
(d -> d') -> Proof d 'Inclusion alg -> Proof d' 'Inclusion alg
mapProofDirection (Direction -> () -> Direction
forall a b. a -> b -> a
const Direction
L) Proof () 'Inclusion alg
p
          rightMerkleRoot :: Digest alg
rightMerkleRoot = Proof Direction 'Inclusion alg -> Digest alg
forall alg.
HashAlgorithm alg =>
Proof Direction 'Inclusion alg -> Digest alg
inclusionProofMerkleRoot (Proof Direction 'Inclusion alg -> Digest alg)
-> Proof Direction 'Inclusion alg -> Digest alg
forall a b. (a -> b) -> a -> b
$ (() -> Direction)
-> Proof () 'Inclusion alg -> Proof Direction 'Inclusion alg
forall d d' alg.
(d -> d') -> Proof d 'Inclusion alg -> Proof d' 'Inclusion alg
mapProofDirection (Direction -> () -> Direction
forall a b. a -> b -> a
const Direction
R) Proof () 'Inclusion alg
q
          includedDigest :: Digest alg
includedDigest = Digest alg -> Digest alg -> Digest alg
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> ba -> Digest a
hashParent Digest alg
leftMerkleRoot Digest alg
rightMerkleRoot
       in MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
forall alg.
HashAlgorithm alg =>
MerkleRoot alg -> Proof Direction 'Inclusion alg -> Bool
validInclusionProof MerkleRoot alg
root (Proof Direction 'Inclusion alg -> Bool)
-> Proof Direction 'Inclusion alg -> Bool
forall a b. (a -> b) -> a -> b
$
            InclusionProof :: forall alg d.
Digest alg -> [(Digest alg, d)] -> Proof d 'Inclusion alg
InclusionProof
              { Digest alg
includedDigest :: Digest alg
$sel:includedDigest:InclusionProof :: Digest alg
includedDigest,
                $sel:rootPath:InclusionProof :: [(Digest alg, Direction)]
rootPath = [(Digest alg, Direction)]
commonRootPath
              }
  Proof Direction 'Exclusion alg
_ -> Bool
False

mapProofDirection :: (d -> d') -> Proof d 'Inclusion alg -> Proof d' 'Inclusion alg
mapProofDirection :: (d -> d') -> Proof d 'Inclusion alg -> Proof d' 'Inclusion alg
mapProofDirection d -> d'
f proof :: Proof d 'Inclusion alg
proof@InclusionProof {[(Digest alg, d)]
rootPath :: [(Digest alg, d)]
$sel:rootPath:InclusionProof :: forall d alg. Proof d 'Inclusion alg -> [(Digest alg, d)]
rootPath} = Proof d 'Inclusion alg
proof {$sel:rootPath:InclusionProof :: [(Digest alg, d')]
rootPath = ((Digest alg, d) -> (Digest alg, d'))
-> [(Digest alg, d)] -> [(Digest alg, d')]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((d -> d') -> (Digest alg, d) -> (Digest alg, d')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap d -> d'
f) [(Digest alg, d)]
rootPath}

-- | Validate a tree against the properties of a compact sparse merkle tree. Namely that:
--
-- * the maximum leaf digests for all subtrees are valid
-- * the leaf hash digests are valid
-- * and all leafs lie on its /minimum distance path/ from the root.
--
-- All exported functions maintain these properties.
--
-- Average case Θ(n*log n), Worst case Θ(n²) where n is the size of the tree.
valid :: (ByteArrayAccess a, HashAlgorithm alg) => CSMT i alg a -> Bool
valid :: CSMT i alg a -> Bool
valid = (Digest alg -> Bool) -> CSMT i alg a -> Bool
forall a alg (i :: Size).
(ByteArrayAccess a, HashAlgorithm alg) =>
(Digest alg -> Bool) -> CSMT i alg a -> Bool
valid' (Bool -> Digest alg -> Bool
forall a b. a -> b -> a
const Bool
True)
  where
    valid' :: (ByteArrayAccess a, HashAlgorithm alg) => (Digest alg -> Bool) -> CSMT i alg a -> Bool
    valid' :: (Digest alg -> Bool) -> CSMT i alg a -> Bool
valid' Digest alg -> Bool
validPath = \case
      Nil {} -> Bool
True
      Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest, a
value :: a
$sel:value:Nil :: forall alg a. CSMT 'NonEmpty alg a -> a
value} -> a -> Digest alg
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Digest a
hashLeaf a
value Digest alg -> Digest alg -> Bool
forall a. Eq a => a -> a -> Bool
== Digest alg
digest Bool -> Bool -> Bool
&& Digest alg -> Bool
validPath Digest alg
digest
      Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left, $sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest = Digest alg
parentDigest, Digest alg
maxDigest :: Digest alg
$sel:maxDigest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maxDigest, CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right} ->
        CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest CSMT 'NonEmpty alg a
left Digest alg -> Digest alg -> Bool
forall a. Ord a => a -> a -> Bool
<= Digest alg
maxDigest
          Bool -> Bool -> Bool
&& CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maximumDigest CSMT 'NonEmpty alg a
right Digest alg -> Digest alg -> Bool
forall a. Ord a => a -> a -> Bool
<= Digest alg
maxDigest
          Bool -> Bool -> Bool
&& Digest alg
parentDigest Digest alg -> Digest alg -> Bool
forall a. Eq a => a -> a -> Bool
== Digest alg -> Digest alg -> Digest alg
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> ba -> Digest a
hashParent (CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest CSMT 'NonEmpty alg a
left) (CSMT 'NonEmpty alg a -> Digest alg
forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest CSMT 'NonEmpty alg a
right)
          Bool -> Bool -> Bool
&& (Digest alg -> Bool) -> CSMT 'NonEmpty alg a -> Bool
forall a alg (i :: Size).
(ByteArrayAccess a, HashAlgorithm alg) =>
(Digest alg -> Bool) -> CSMT i alg a -> Bool
valid' (\Digest alg
h -> Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
forall alg a.
Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
compareSubTrees Digest alg
h CSMT 'NonEmpty alg a
left CSMT 'NonEmpty alg a
right Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT Bool -> Bool -> Bool
&& Digest alg -> Bool
validPath Digest alg
h) CSMT 'NonEmpty alg a
left
          Bool -> Bool -> Bool
&& (Digest alg -> Bool) -> CSMT 'NonEmpty alg a -> Bool
forall a alg (i :: Size).
(ByteArrayAccess a, HashAlgorithm alg) =>
(Digest alg -> Bool) -> CSMT i alg a -> Bool
valid' (\Digest alg
h -> Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
forall alg a.
Digest alg
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering
compareSubTrees Digest alg
h CSMT 'NonEmpty alg a
left CSMT 'NonEmpty alg a
right Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT Bool -> Bool -> Bool
&& Digest alg -> Bool
validPath Digest alg
h) CSMT 'NonEmpty alg a
right

-- | Create a tree from a list of elements.
--
-- Average case Θ(n*log n), Worst case Θ(n²) where n is the size of the tree.
fromList :: (ByteArrayAccess a, HashAlgorithm alg) => NonEmpty a -> CSMT 'NonEmpty alg a
fromList :: NonEmpty a -> CSMT 'NonEmpty alg a
fromList = \case
  (a
x :| []) -> a -> CSMT 'NonEmpty alg a
forall a alg.
(ByteArrayAccess a, HashAlgorithm alg) =>
a -> CSMT 'NonEmpty alg a
singleton a
x
  (a
x :| a
y : [a]
ys) -> a -> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall a alg (i :: Size).
(ByteArrayAccess a, HashAlgorithm alg) =>
a -> CSMT i alg a -> CSMT 'NonEmpty alg a
insert a
x (CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a)
-> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
forall a b. (a -> b) -> a -> b
$ NonEmpty a -> CSMT 'NonEmpty alg a
forall a alg.
(ByteArrayAccess a, HashAlgorithm alg) =>
NonEmpty a -> CSMT 'NonEmpty alg a
fromList (a
y a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
ys)

--------------------------------------------------------------------------------

-- | The depth of a tree.
--
-- Average case Θ(n), Worst case Θ(n) where n is the size of the tree.
depth :: (Num n, Ord n) => CSMT i alg a -> n
depth :: CSMT i alg a -> n
depth = \case
  CSMT i alg a
Nil -> n
0
  Leaf {} -> n
1
  Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left, CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right} -> n
1 n -> n -> n
forall a. Num a => a -> a -> a
+ n -> n -> n
forall a. Ord a => a -> a -> a
max (CSMT 'NonEmpty alg a -> n
forall n (i :: Size) alg a. (Num n, Ord n) => CSMT i alg a -> n
depth CSMT 'NonEmpty alg a
left) (CSMT 'NonEmpty alg a -> n
forall n (i :: Size) alg a. (Num n, Ord n) => CSMT i alg a -> n
depth CSMT 'NonEmpty alg a
right)

-- | Convert a tree to a rose tree with non-recursive nodes as elements.
-- Used for debugging purposes.
--
-- Average case Θ(n), Worst case Θ(n) where n is the size of the tree.
toTree :: CSMT i alg a -> Maybe (Tree (DataNode alg a))
toTree :: CSMT i alg a -> Maybe (Tree (DataNode alg a))
toTree = \case
  CSMT i alg a
Nil -> Maybe (Tree (DataNode alg a))
forall a. Maybe a
Nothing
  Leaf {Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest, a
value :: a
$sel:value:Nil :: forall alg a. CSMT 'NonEmpty alg a -> a
value} ->
    Tree (DataNode alg a) -> Maybe (Tree (DataNode alg a))
forall a. a -> Maybe a
Just (Tree (DataNode alg a) -> Maybe (Tree (DataNode alg a)))
-> Tree (DataNode alg a) -> Maybe (Tree (DataNode alg a))
forall a b. (a -> b) -> a -> b
$
      DataNode alg a -> Forest (DataNode alg a) -> Tree (DataNode alg a)
forall a. a -> Forest a -> Tree a
Tree.Node
        ( ExternalNode :: forall alg a. Digest alg -> a -> DataNode alg a
DN.ExternalNode
            { Digest alg
digest :: Digest alg
digest :: Digest alg
digest,
              a
value :: a
value :: a
value
            }
        )
        []
  Parent {CSMT 'NonEmpty alg a
left :: CSMT 'NonEmpty alg a
$sel:left:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
left, Digest alg
digest :: Digest alg
$sel:digest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
digest, Digest alg
maxDigest :: Digest alg
$sel:maxDigest:Nil :: forall alg a. CSMT 'NonEmpty alg a -> Digest alg
maxDigest, CSMT 'NonEmpty alg a
right :: CSMT 'NonEmpty alg a
$sel:right:Nil :: forall alg a. CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a
right} ->
    Tree (DataNode alg a) -> Maybe (Tree (DataNode alg a))
forall a. a -> Maybe a
Just (Tree (DataNode alg a) -> Maybe (Tree (DataNode alg a)))
-> Tree (DataNode alg a) -> Maybe (Tree (DataNode alg a))
forall a b. (a -> b) -> a -> b
$
      DataNode alg a -> Forest (DataNode alg a) -> Tree (DataNode alg a)
forall a. a -> Forest a -> Tree a
Tree.Node
        ( InternalNode :: forall alg a. Digest alg -> Digest alg -> DataNode alg a
DN.InternalNode
            { Digest alg
digest :: Digest alg
digest :: Digest alg
digest,
              Digest alg
maxDigest :: Digest alg
maxDigest :: Digest alg
maxDigest
            }
        )
        (Forest (DataNode alg a) -> Tree (DataNode alg a))
-> Forest (DataNode alg a) -> Tree (DataNode alg a)
forall a b. (a -> b) -> a -> b
$ (CSMT 'NonEmpty alg a -> Maybe (Tree (DataNode alg a)))
-> [CSMT 'NonEmpty alg a] -> Forest (DataNode alg a)
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CSMT 'NonEmpty alg a -> Maybe (Tree (DataNode alg a))
forall (i :: Size) alg a.
CSMT i alg a -> Maybe (Tree (DataNode alg a))
toTree [CSMT 'NonEmpty alg a
left, CSMT 'NonEmpty alg a
right]

-- | 2-dimensional ASCII drawing of the tree.
-- Used for debugging purposes.
--
-- Average case Θ(n²), Worst case Θ(n²) where n is the size of the tree.
drawTree :: Show a => CSMT i alg a -> String
drawTree :: CSMT i alg a -> String
drawTree = String
-> (Tree (DataNode alg a) -> String)
-> Maybe (Tree (DataNode alg a))
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (Tree String -> String
Tree.drawTree (Tree String -> String)
-> (Tree (DataNode alg a) -> Tree String)
-> Tree (DataNode alg a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataNode alg a -> String) -> Tree (DataNode alg a) -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataNode alg a -> String
forall a. Show a => a -> String
show) (Maybe (Tree (DataNode alg a)) -> String)
-> (CSMT i alg a -> Maybe (Tree (DataNode alg a)))
-> CSMT i alg a
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSMT i alg a -> Maybe (Tree (DataNode alg a))
forall (i :: Size) alg a.
CSMT i alg a -> Maybe (Tree (DataNode alg a))
toTree