packages feed

sparse-merkle-trees (empty) → 0.2.0.0

raw patch · 9 files changed

+1198/−0 lines, 9 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, criterion, cryptonite, deepseq, memory, smallcheck, sparse-merkle-trees, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck

Files

+ CHANGELOG.md view
@@ -0,0 +1,17 @@+# 0.2.0.0 (2022-05-25)+++* build!: unexpose DataNote ([5b095d5](https://github.com/tochicool/sparse-merkle-trees/commit/5b095d5954575dd0dd04b16bb3fda775445ae3fb))+++### Features++* **csmt:** implementation ([83c19ef](https://github.com/tochicool/sparse-merkle-trees/commit/83c19ef45b5694be1bf6c9f4d77fecdb39069fd6))+++### BREAKING CHANGES++* the `Crypto.Hash.CompactSparseMerkleTree.DataNode` is no longer exported+++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tochi Obudulu (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tochi Obudulu nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,130 @@+# sparse-merkle-trees++[![CI/CD](https://github.com/tochicool/sparse-merkle-trees/actions/workflows/cicd.yaml/badge.svg)](https://github.com/tochicool/sparse-merkle-trees/actions/workflows/cicd.yaml)+[![Hackage](https://img.shields.io/hackage/v/sparse-merkle-trees)](https://hackage.haskell.org/package/sparse-merkle-trees)+[![BSD3](https://img.shields.io/github/license/tochicool/sparse-merkle-trees)](https://github.com/tochicool/sparse-merkle-trees/blob/master/LICENSE)++A Haskell library implementing sparse Merkle trees, an authenticated data +structure with support for zero-knowledge proofs of *inclusion and exclusion*, +parametrised over cryptographic hash algorithms at the type level.+++> **Note**: This library is currently experimental and is subject to change.++## Introduction++A [Merkle tree](https://en.wikipedia.org/wiki/Merkle_tree) is an authenticated +data structure which supports efficient zero-knowledge proofs of element +inclusion from a Merkle root.++A sparse Merkle tree (SMT) is Merkle Tree where all possible keys (digests) are +at the leaves of the tree. This gives us the additional properties over a Merkle +tree:++* support for proofs of *exclusion* of elements from a Merkle root+* *history independence* of the merkle root from element insertion order++A naive construction would mean that a N-bit key would yield a SMT of size +2^N. However, because the tree is *sparse*, there are efficient constructions+that grow in size O(n) where n is the size of the tree.++### Use cases++SMTs expand on the existing use cases of Merkle trees including:++* Asset universes+* Certificate revocation+* Secure file systems+* Secure messaging++## Examples++### Compact Sparse Merkle Trees++The compact sparse Merkle tree is based on the description given in this +[report](https://eprint.iacr.org/2018/955.pdf) by +[Faraz Haider](https://github.com/farazhaider). The module exposes an similar +API to [`Data.Set`](https://hackage.haskell.org/package/containers-0.6.5.1/docs/Data-Set.html) but this is subject to change.++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++import Crypto.Hash (SHA256) -- from cryptonite package+import Crypto.Hash.CompactSparseMerkleTree (CSMT, MembershipProof, MerkleRoot, Size (NonEmpty))+import qualified Crypto.Hash.CompactSparseMerkleTree as CSMT+import Data.ByteString (ByteString) -- from bytestring package++type MailingList = CSMT 'NonEmpty SHA256 ByteString++cypherPunks :: MailingList+cypherPunks =+  CSMT.insert "hal@finney.org" $+    CSMT.insert "satoshi@vistomail.com" $+      CSMT.insert "aba@dcs.ex.ac.uk" $+        CSMT.insert "szabo@techbook.com" $+          CSMT.insert "weidai@eskimo.com" $+            CSMT.empty++summary :: MerkleRoot SHA256+summary = CSMT.merkleRoot cypherPunks++-- >>> summary+-- MerkleRoot b7061997fc49294bfb5c8893a684eea53d20f11d152530fbb95b3fc5ca902d2a++nakamotoProof :: MembershipProof SHA256+nakamotoProof = CSMT.membershipProof "satoshi@vistomail.com" cypherPunks++-- >>> nakamotoProof+-- MembershipProof (InclusionProof {includedDigest = 4a2220676a74d2be6d0c00d939513a3b5599bd01c65cf3d1ce2d517f070a1c11, rootPath = [(5554c052244897a83ef61362e6a3141c034284b54f4977163070d634749a714c,R),(6c98a4128b8a86d5f646707d860a869244938b95177298c6746da5e1e981426e,R),(e1a4e69d03cd197af06688aafb33d50db1d7c407be747b4b9d46c877f2e97fa1,R)]})++szaboTechbookProof :: MembershipProof SHA256+szaboTechbookProof = CSMT.membershipProof "szabo@techbook.com" cypherPunks++-- >>> szaboTechbookProof+-- MembershipProof (InclusionProof {includedDigest = 5554c052244897a83ef61362e6a3141c034284b54f4977163070d634749a714c, rootPath = [(4a2220676a74d2be6d0c00d939513a3b5599bd01c65cf3d1ce2d517f070a1c11,L),(6c98a4128b8a86d5f646707d860a869244938b95177298c6746da5e1e981426e,R),(e1a4e69d03cd197af06688aafb33d50db1d7c407be747b4b9d46c877f2e97fa1,R)]})++szaboNetcomProof :: MembershipProof SHA256+szaboNetcomProof = CSMT.membershipProof "szabo@netcom.com" cypherPunks++-- >>> szaboNetcomProof+-- MembershipProof (ExclusionProof {excludedDigest = 8f3af01ec764fa90a9bb98b1547656e362640fc336cf31c80b7dfacb50f2d256, immediatePredecessor = Just (InclusionProof {includedDigest = 6c98a4128b8a86d5f646707d860a869244938b95177298c6746da5e1e981426e, rootPath = [(0fa34cea30d143cb5bbfd6937e3848c8faf4d0737b88b55fbcb0f2afac94e6b3,())]}), immediateSuccessor = Just (InclusionProof {includedDigest = 949802fb7f855457ede853818031b82bc5f446c7369f7abe6fa9e564dde18e96, rootPath = [(dc2baa959e086c741627d36a0804a302590b11e44590936621e81acd4a528de4,())]}), commonRootPath = []})++cypherPunks' :: MailingList+cypherPunks' = CSMT.delete "szabo@techbook.com" (CSMT.insert "szabo@netcom.com" cypherPunks) $ \case+  t@CSMT.Parent {} -> t+  _ -> error "impossible"++summary' :: MerkleRoot SHA256+summary' = CSMT.merkleRoot cypherPunks'++-- >>> summary'+-- MerkleRoot 7dc6b4dfcd54f9c6ac67a330b35539407c2e9559d7e589e6064f1c8a46256aa7++szaboTechbookProof' :: MembershipProof SHA256+szaboTechbookProof' = CSMT.membershipProof "szabo@techbook.com" cypherPunks'++-- >>> szaboTechbookProof'+-- MembershipProof (ExclusionProof {excludedDigest = 5554c052244897a83ef61362e6a3141c034284b54f4977163070d634749a714c, immediatePredecessor = Just (InclusionProof {includedDigest = 4a2220676a74d2be6d0c00d939513a3b5599bd01c65cf3d1ce2d517f070a1c11, rootPath = []}), immediateSuccessor = Just (InclusionProof {includedDigest = 6c98a4128b8a86d5f646707d860a869244938b95177298c6746da5e1e981426e, rootPath = []}), commonRootPath = [(b8804f3bbe10963f35ee72dbd55a8aa33b64260ab0c63bff59acc13ea8088e56,R)]})++szaboNetcomProof' :: MembershipProof SHA256+szaboNetcomProof' = CSMT.membershipProof "szabo@netcom.com" cypherPunks'++-- >>> szaboNetcomProof+-- MembershipProof (ExclusionProof {excludedDigest = 8f3af01ec764fa90a9bb98b1547656e362640fc336cf31c80b7dfacb50f2d256, immediatePredecessor = Just (InclusionProof {includedDigest = 6c98a4128b8a86d5f646707d860a869244938b95177298c6746da5e1e981426e, rootPath = [(0fa34cea30d143cb5bbfd6937e3848c8faf4d0737b88b55fbcb0f2afac94e6b3,())]}), immediateSuccessor = Just (InclusionProof {includedDigest = 949802fb7f855457ede853818031b82bc5f446c7369f7abe6fa9e564dde18e96, rootPath = [(dc2baa959e086c741627d36a0804a302590b11e44590936621e81acd4a528de4,())]}), commonRootPath = []})++-- >>> all (CSMT.validProof summary) [nakamotoProof, szaboTechbookProof, szaboNetcomProof]+-- True+-- >>> all (CSMT.validProof summary') [szaboTechbookProof', szaboNetcomProof']+-- True+-- >>> CSMT.validProof summary' nakamotoProof+-- False+```+See the more complete haddock documentation on [Hackage](https://hackage.haskell.org/package/sparse-merkle-trees).++## Related libraries++* [cryptonite](https://hackage.haskell.org/package/cryptonite) for cryptographic primitives+* [merkle-tree](https://hackage.haskell.org/package/merkle-tree) for an implementation of a merkle tree
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DataKinds #-}++{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}++import Control.DeepSeq (NFData (rnf))+import Criterion.Main+import Crypto.Hash (HashAlgorithm, SHA256)+import Crypto.Hash.CompactSparseMerkleTree+import Data.ByteArray (ByteArrayAccess)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Foldable (toList)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.String (IsString)+import Test.QuickCheck (Arbitrary (arbitrary), Gen)+import qualified Test.QuickCheck as QC++type BenchmarkCSMT = CSMT 'NonEmpty SHA256 Data++instance NFData a => NFData (CSMT i alg a) where+  rnf = \case+    Nil {} -> rnf ()+    Leaf {digest, value} ->+      rnf digest `seq` rnf value+    Parent {left, digest, maxDigest, right} ->+      rnf left `seq` rnf digest `seq` rnf maxDigest `seq` rnf right++newtype Data = Data ByteString+  deriving (IsString, Eq, Show, ByteArrayAccess, NFData)++instance Arbitrary Data where+  arbitrary = fmap (Data . BS.pack . ("data-" <>) . show . QC.getNonNegative) (QC.arbitrary :: QC.Gen (QC.NonNegative Integer))++instance Arbitrary (CSMT 'Empty alg a) where+  arbitrary = return empty++instance (Arbitrary a, ByteArrayAccess a, HashAlgorithm alg) => Arbitrary (CSMT 'NonEmpty alg a) where+  arbitrary = do+    arbitrary >>= \case+      QC.NonEmpty (x : xs) -> return $ fromList $ x :| xs+      _ -> error "impossible"++treeOfSize :: Integer -> Gen BenchmarkCSMT+treeOfSize 1 = return $ singleton "data-0"+treeOfSize n = do+  let x = Data $ BS.pack $ "data-" <> show (n - 1)+  insert x <$> treeOfSize (n - 1)++membershipTestOfSize :: Integer -> Gen (Data, BenchmarkCSMT)+membershipTestOfSize n = do+  t <- treeOfSize n+  x <- QC.oneof [elementIn t, elementNotIn t]+  return (x, t)++elementIn :: BenchmarkCSMT -> Gen Data+elementIn = QC.elements . toList++elementNotIn :: BenchmarkCSMT -> Gen Data+elementNotIn t = arbitrary `QC.suchThat` (`notMember` t)++main :: IO ()+main =+  defaultMain+    [ bgroup+        "CSMT"+        [ benchSizes+            (upTo 10000)+            "maximumDigest"+            (QC.generate . treeOfSize)+            $ nf maximumDigest,+          benchSizes+            (upTo 10000)+            "minimumDigest"+            (QC.generate . treeOfSize)+            $ nf minimumDigest,+          benchSizes+            (upTo 1000)+            "member"+            (QC.generate . membershipTestOfSize)+            $ \ ~(x, t) -> nf (member x) t,+          benchSizes+            (upTo 1000)+            "insert"+            (QC.generate . membershipTestOfSize)+            $ \ ~(x, t) -> nf (insert x) t+        ]+    ]++benchSizes :: (NFData t, Show a) => [a] -> String -> (a -> IO t) -> (t -> Benchmarkable) -> Benchmark+benchSizes ns name e b = bgroup name $+  flip map ns $ \n ->+    env (e n) $ \x ->+      bench (show n) $ b x++upTo :: Integral a => a -> [a]+upTo n = go [n]+  where+    go (x : xs) | x > 10 = go (x `div` 10 : x : xs)+    go xs = xs
+ sparse-merkle-trees.cabal view
@@ -0,0 +1,85 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           sparse-merkle-trees+version:        0.2.0.0+synopsis:       Sparse Merkle trees with proofs of inclusion and exclusion+description:    Please see the README on GitHub at <https://github.com/tochicool/sparse-merkle-trees#readme>+category:       Cryptography,Data Structures+homepage:       https://github.com/tochicool/sparse-merkle-trees#readme+bug-reports:    https://github.com/tochicool/sparse-merkle-trees/issues+author:         Tochi Obudulu+maintainer:     tochicool@gmail.com+copyright:      Copyright (c) 2022 Tochi Obudulu+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/tochicool/sparse-merkle-trees++library+  exposed-modules:+      Crypto.Hash.CompactSparseMerkleTree+  other-modules:+      Crypto.Hash.CompactSparseMerkleTree.DataNode+      Paths_sparse_merkle_trees+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.10 && <0.12+    , containers ==0.6.*+    , cryptonite >=0.25 && <0.31+    , memory >=0.14 && <0.18+  default-language: Haskell2010++test-suite sparse-merkle-trees-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_sparse_merkle_trees+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.10 && <0.12+    , containers ==0.6.*+    , cryptonite >=0.25 && <0.31+    , memory >=0.14 && <0.18+    , smallcheck+    , sparse-merkle-trees+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , tasty-smallcheck+  default-language: Haskell2010++benchmark sparse-merkle-trees-bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_sparse_merkle_trees+  hs-source-dirs:+      bench+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , bytestring >=0.10 && <0.12+    , containers ==0.6.*+    , criterion+    , cryptonite >=0.25 && <0.31+    , deepseq+    , memory >=0.14 && <0.18+    , sparse-merkle-trees+  default-language: Haskell2010
+ src/Crypto/Hash/CompactSparseMerkleTree.hs view
@@ -0,0 +1,630 @@+{-# 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.+      digest :: Digest alg,+      -- | The data value.+      value :: a+    } ->+    CSMT 'NonEmpty alg a+  -- | A parent node.+  Parent ::+    { -- | The left non-empty subtree.+      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.+      maxDigest :: Digest alg,+      -- | The right non-empty subtree.+      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 eq m n = liftEq eq (toList m) (toList n)++instance Ord1 (CSMT i alg) where+  liftCompare cmp m n = liftCompare cmp (toList m) (toList n)++-- | The empty tree.+--+-- Worst case Θ(1).+empty :: CSMT 'Empty alg a+empty = Nil++-- | Create a singleton tree.+--+-- Worst case Θ(1).+singleton :: (ByteArrayAccess a, HashAlgorithm alg) => a -> CSMT 'NonEmpty alg a+singleton x = singletonDigest (hashLeaf x) x++singletonDigest :: Digest alg -> a -> CSMT 'NonEmpty alg a+singletonDigest h x = Leaf {digest = h, value = 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 x = insertDigest (hashLeaf x) x++insertDigest :: (ByteArrayAccess a, HashAlgorithm alg) => Digest alg -> a -> CSMT i alg a -> CSMT 'NonEmpty alg a+insertDigest h x = \case+  Nil -> singletonDigest h x+  root@Leaf {} ->+    let newLeaf = singletonDigest h x+     in case h `compare` maximumDigest root of+          LT -> parent newLeaf root+          EQ -> singletonDigest h x+          GT -> parent root newLeaf+  root@Parent {left, right} ->+    case compareSubTrees h left right of+      EQ ->+        let newLeaf = singletonDigest h x+            minKey = min (maximumDigest left) (maximumDigest right)+         in case h `compare` minKey of+              LT -> parent newLeaf root+              __ -> parent root newLeaf+      LT -> parent (insertDigest h x left) right+      GT -> parent left (insertDigest h x 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 x = deleteDigest (hashLeaf x)++deleteDigest :: HashAlgorithm alg => Digest alg -> CSMT i alg a -> (forall j. CSMT j alg a -> b) -> b+deleteDigest h root returnTree = case root of+  Nil {} -> returnTree root+  Leaf {digest}+    | h == digest -> returnTree empty+    | otherwise -> returnTree root+  Parent {left, right} ->+    case compareSubTrees h left right of+      EQ -> returnTree root+      LT -> deleteDigest h left $ \case+        Nil {} -> returnTree right+        left'@Leaf {} -> returnTree $ parent left' right+        left'@Parent {} -> returnTree $ parent left' right+      GT -> deleteDigest h right $ \case+        Nil {} -> returnTree left+        right'@Leaf {} -> returnTree $ parent left right'+        right'@Parent {} -> returnTree $ parent left right'++compareSubTrees :: Digest alg -> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> Ordering+compareSubTrees h = comparing (distance h . maximumDigest)++distance :: Digest alg -> Digest alg -> Int+distance a = logBase2 . BA.xor a+  where+    logBase2 x =+      8 * BS.length x - 1 - case span (== 0) (BS.unpack x) of+        (zeros, nonZeros) ->+          8 * length zeros + case nonZeros of+            [] -> 0+            (w : _) -> countLeadingZeros w++-- | The maximum digest in the tree.+--+-- Worst case Θ(1).+maximumDigest :: CSMT 'NonEmpty alg a -> Digest alg+maximumDigest Leaf {digest} = digest+maximumDigest Parent {maxDigest} = 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 = \case+  Leaf {digest} -> digest+  Parent {left} -> minimumDigest left++parent :: HashAlgorithm alg => CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a -> CSMT 'NonEmpty alg a+parent left right =+  Parent+    { left,+      digest = hashParent (digest left) (digest right),+      maxDigest = max (maximumDigest left) (maximumDigest right),+      right+    }++hashLeaf :: (HashAlgorithm a, ByteArrayAccess ba) => ba -> Digest a+hashLeaf = hashFinalize . hashUpdate (hashUpdate hashInit (BS.singleton 0))++hashParent :: (HashAlgorithm a, ByteArrayAccess ba) => ba -> ba -> Digest a+hashParent x y = hashFinalize $ hashUpdates (hashUpdate hashInit (BS.singleton 1)) [x, 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.+      includedDigest :: Digest alg,+      -- | A list of sibling digests from the root to the included element with the directions from their parents.+      rootPath :: [(Digest alg, d)]+    } ->+    Proof d 'Inclusion alg+  -- | A proof of exclusion.+  ExclusionProof ::+    { -- | The digest of an excluded element.+      excludedDigest :: Digest alg,+      -- | A uni-directional inclusion proof from the left of the immediate predecessor to the included element, if one exists.+      immediatePredecessor :: Maybe (Proof () 'Inclusion alg),+      -- | A uni-directional inclusion proof from the right of the immediate successor to the included element, if one exists.+      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.+      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 (Show, 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 x = isInclusionProof . membershipProof 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 x = not . member 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 h = \case+  Nil {} -> Nothing+  Leaf {digest, value}+    | h == digest -> Just value+    | otherwise -> Nothing+  Parent {left, right} ->+    case compareSubTrees h left right of+      EQ -> Nothing+      LT -> lookup h left+      GT -> lookup h right++-- | Is this an inclusion proof?+--+-- Worst case Θ(1).+isInclusionProof :: MembershipProof alg -> Bool+isInclusionProof = \case+  MembershipProof (InclusionProof {}) -> True+  _ -> False++-- | Is this an exclusion proof?+--+-- Worst case Θ(1).+isExclusionProof :: MembershipProof alg -> Bool+isExclusionProof = not . 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 x = membershipProofDigest [] (hashLeaf x)++membershipProofDigest :: [(CSMT 'NonEmpty alg a, Direction)] -> Digest alg -> CSMT i alg a -> MembershipProof alg+membershipProofDigest path h = \case+  Nil {} ->+    MembershipProof $ trivialExclusionProof h+  leaf@Leaf {digest} -> case h `compare` digest of+    EQ ->+      MembershipProof (trivialInclusionProof digest) {rootPath = toRootPath path}+    __ -> nonMembershipProof path h leaf+  root@Parent {left, right} ->+    case compareSubTrees h left right of+      EQ -> case h `compare` maximumDigest root of+        LT -> nonMembershipProof ((right, R) : path) h left+        __ -> nonMembershipProof ((left, L) : path) h right+      LT -> membershipProofDigest ((right, R) : path) h left+      GT -> membershipProofDigest ((left, L) : path) h right++nonMembershipProof :: [(CSMT 'NonEmpty alg a, Direction)] -> Digest alg -> CSMT 'NonEmpty alg a -> MembershipProof alg+nonMembershipProof path h t =+  let exclusionProof = trivialExclusionProof h+   in case h `compare` maximumDigest t of+        LT ->+          case spanDirection R path of+            (successorPath, []) ->+              MembershipProof $+                exclusionProof+                  { immediateSuccessor = Just $ minimumDigestInclusionProof' successorPath t+                  }+            (successorPath, (sibling, _) : commonPath) ->+              MembershipProof $+                exclusionProof+                  { immediateSuccessor = Just $ minimumDigestInclusionProof' successorPath t,+                    immediatePredecessor = Just $ maximumDigestInclusionProof sibling,+                    commonRootPath = toRootPath commonPath+                  }+        __ ->+          case spanDirection L path of+            (predecessorPath, []) ->+              MembershipProof $+                exclusionProof+                  { immediatePredecessor = Just $ maximumDigestInclusionProof' predecessorPath t+                  }+            (predecessorPath, (sibling, _) : commonPath) ->+              MembershipProof $+                exclusionProof+                  { immediatePredecessor = Just $ maximumDigestInclusionProof' predecessorPath t,+                    immediateSuccessor = Just $ minimumDigestInclusionProof sibling,+                    commonRootPath = toRootPath commonPath+                  }++spanDirection :: Eq d => d -> [(CSMT 'NonEmpty alg a, d)] -> ([(Digest alg, ())], [(CSMT 'NonEmpty alg a, d)])+spanDirection d = first toUniRootPath . span ((d ==) . snd)++toUniRootPath :: [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, ())]+toUniRootPath = fmap void . toRootPath++toRootPath :: [(CSMT 'NonEmpty alg a, d)] -> [(Digest alg, d)]+toRootPath = fmap (first digest)++trivialInclusionProof :: Digest alg -> Proof d 'Inclusion alg+trivialInclusionProof h =+  InclusionProof+    { includedDigest = h,+      rootPath = mempty+    }++trivialExclusionProof :: Digest alg -> Proof d 'Exclusion alg+trivialExclusionProof h =+  ExclusionProof+    { excludedDigest = h,+      commonRootPath = [],+      immediatePredecessor = Nothing,+      immediateSuccessor = Nothing+    }++maximumDigestInclusionProof :: CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg+maximumDigestInclusionProof = maximumDigestInclusionProof' []++maximumDigestInclusionProof' :: [(Digest alg, ())] -> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg+maximumDigestInclusionProof' path = \case+  Leaf {digest} -> (trivialInclusionProof digest) {rootPath = path}+  Parent {left, right} -> maximumDigestInclusionProof' ((digest left, ()) : path) right++minimumDigestInclusionProof :: CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg+minimumDigestInclusionProof = minimumDigestInclusionProof' []++minimumDigestInclusionProof' :: [(Digest alg, ())] -> CSMT 'NonEmpty alg a -> Proof () 'Inclusion alg+minimumDigestInclusionProof' path = \case+  Leaf {digest} -> (trivialInclusionProof digest) {rootPath = path}+  Parent {left, right} -> minimumDigestInclusionProof' ((digest right, ()) : path) 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 (Show, Eq)++-- | The merkle root of a tree.+--+-- Worst case Θ(1).+merkleRoot :: CSMT i alg a -> MerkleRoot alg+merkleRoot = \case+  Nil {} -> EmptyMerkleRoot+  Leaf {digest} -> MerkleRoot digest+  Parent {digest} -> MerkleRoot 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 root = \case+  MembershipProof proof@InclusionProof {} -> validInclusionProof root proof+  MembershipProof proof@ExclusionProof {} -> validExclusionProof root 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 EmptyMerkleRoot _ = False+validInclusionProof (MerkleRoot root) proof = root == inclusionProofMerkleRoot proof++inclusionProofMerkleRoot :: HashAlgorithm alg => Proof Direction 'Inclusion alg -> Digest alg+inclusionProofMerkleRoot InclusionProof {includedDigest, rootPath} =+  foldl'+    ( \result (siblingDigest, direction) -> uncurry hashParent $+        case direction of+          L -> (siblingDigest, result)+          R -> (result, siblingDigest)+    )+    includedDigest+    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 root = \case+  ExclusionProof {immediatePredecessor = Nothing, immediateSuccessor = Nothing} ->+    root == EmptyMerkleRoot+  ExclusionProof {immediatePredecessor = Just p, excludedDigest, immediateSuccessor = Nothing}+    | includedDigest p < excludedDigest ->+      validInclusionProof root $ mapProofDirection (const L) p+  ExclusionProof {immediatePredecessor = Nothing, excludedDigest, immediateSuccessor = Just q}+    | excludedDigest < includedDigest q ->+      validInclusionProof root $ mapProofDirection (const R) q+  ExclusionProof {immediatePredecessor = Just p, commonRootPath, excludedDigest, immediateSuccessor = Just q}+    | includedDigest p < excludedDigest,+      excludedDigest < includedDigest q ->+      let leftMerkleRoot = inclusionProofMerkleRoot $ mapProofDirection (const L) p+          rightMerkleRoot = inclusionProofMerkleRoot $ mapProofDirection (const R) q+          includedDigest = hashParent leftMerkleRoot rightMerkleRoot+       in validInclusionProof root $+            InclusionProof+              { includedDigest,+                rootPath = commonRootPath+              }+  _ -> False++mapProofDirection :: (d -> d') -> Proof d 'Inclusion alg -> Proof d' 'Inclusion alg+mapProofDirection f proof@InclusionProof {rootPath} = proof {rootPath = fmap (fmap f) 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 = valid' (const True)+  where+    valid' :: (ByteArrayAccess a, HashAlgorithm alg) => (Digest alg -> Bool) -> CSMT i alg a -> Bool+    valid' validPath = \case+      Nil {} -> True+      Leaf {digest, value} -> hashLeaf value == digest && validPath digest+      Parent {left, digest = parentDigest, maxDigest, right} ->+        maximumDigest left <= maxDigest+          && maximumDigest right <= maxDigest+          && parentDigest == hashParent (digest left) (digest right)+          && valid' (\h -> compareSubTrees h left right == LT && validPath h) left+          && valid' (\h -> compareSubTrees h left right == GT && validPath h) 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 = \case+  (x :| []) -> singleton x+  (x :| y : ys) -> insert x $ fromList (y :| 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 = \case+  Nil -> 0+  Leaf {} -> 1+  Parent {left, right} -> 1 + max (depth left) (depth 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 = \case+  Nil -> Nothing+  Leaf {digest, value} ->+    Just $+      Tree.Node+        ( DN.ExternalNode+            { digest,+              value+            }+        )+        []+  Parent {left, digest, maxDigest, right} ->+    Just $+      Tree.Node+        ( DN.InternalNode+            { digest,+              maxDigest+            }+        )+        $ mapMaybe toTree [left, 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 = maybe "" (Tree.drawTree . fmap show) . toTree
+ src/Crypto/Hash/CompactSparseMerkleTree/DataNode.hs view
@@ -0,0 +1,13 @@+module Crypto.Hash.CompactSparseMerkleTree.DataNode where+import Crypto.Hash (Digest)++data DataNode alg a+  = ExternalNode+      { digest :: Digest alg,+        value :: a+      }+  | InternalNode+      { digest :: Digest alg,+        maxDigest :: Digest alg+      }+  deriving (Show)
+ test/Spec.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}++import Crypto.Hash (HashAlgorithm, SHA256)+import Crypto.Hash.CompactSparseMerkleTree+import Data.ByteArray (ByteArrayAccess)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Functor.Identity (Identity)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Maybe (isNothing)+import Data.String (IsString)+import Test.SmallCheck.Series (Serial (series), Series, cons0)+import qualified Test.SmallCheck.Series as SC+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck (Arbitrary, Gen)+import qualified Test.Tasty.QuickCheck as QC+import qualified Test.Tasty.SmallCheck as SC+import Prelude hiding (lookup)++newtype Data = Data ByteString+  deriving newtype (IsString, Eq, Show, ByteArrayAccess)++instance Monad m => Serial m Data where+  series = fmap (Data . BS.pack . ("data-" <>) . show) (series :: Series m (SC.NonNegative Integer))++instance Monad m => Serial m (CSMT 'Empty alg a) where+  series = cons0 Nil++instance (Monad m, Serial Identity a, ByteArrayAccess a, HashAlgorithm alg) => Serial m (CSMT 'NonEmpty alg a) where+  series = SC.generate $ \d -> do+    case SC.listSeries d of+      [] -> []+      (x : xs) -> scanl (flip insert) (singleton x) xs++instance Arbitrary Data where+  arbitrary = fmap (Data . BS.pack . ("data-" <>) . show . QC.getNonNegative) (QC.arbitrary :: Gen (QC.NonNegative Integer))++instance Arbitrary (CSMT 'Empty alg a) where+  arbitrary = return empty++instance (Arbitrary a, ByteArrayAccess a, HashAlgorithm alg) => Arbitrary (CSMT 'NonEmpty alg a) where+  arbitrary = do+    QC.arbitrary >>= \case+      QC.NonEmpty (x : xs) -> return $ fromList $ x :| xs+      _ -> error "impossible"++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [unitTests, properties]++properties :: TestTree+properties = testGroup "Properties" [scProps, qcProps]++scProps :: TestTree+scProps =+  testGroup+    "(checked by SmallCheck)"+    [ SC.testProperty "x `member` foldr insert (insert x xs) ys" $+        \(x :: Data, xs :: SC.NonEmpty Data, ys :: [Data]) ->+          x `member` foldr insert (insert x (scFromList xs :: UnderTest)) ys,+      SC.testProperty "x `member` xs ==> digest (singleton x) `lookup` xs = Just x" $+        \(x :: Data, xs :: UnderTest) ->+          x `member` xs SC.==> (digest (singleton x) `lookup` xs == Just x),+      SC.testProperty "x `notMember` delete x (foldr insert (insert x xs) ys)" $+        \(x :: Data, xs :: SC.NonEmpty Data, ys :: [Data]) ->+          delete x (foldr insert (insert x (scFromList xs :: UnderTest)) ys) (x `notMember`),+      SC.testProperty "x `notMember` xs ==> digest (singleton x) `lookup` xs = Nothing" $+        \(x :: Data, xs :: UnderTest) ->+          x `notMember` xs SC.==> isNothing (digest (singleton x) `lookup` xs),+      SC.testProperty "delete x (insert x empty) = empty" $+        \x ->+          ( delete x (insert x empty :: UnderTest) $ \case+              Nil {} -> True+              _ -> False+          ) ::+            Bool,+      SC.testProperty "delete x (insert x xs) = delete x xs" $+        \(x :: Data, ys :: SC.NonEmpty Data) ->+          let xs :: UnderTest = scFromList ys+           in ( delete x xs $ \case+                  Nil {} -> delete x (insert x xs) null+                  t@Leaf {} -> delete x (insert x xs) $ \case+                    t'@Leaf {} -> t == t'+                    _ -> False+                  t@Parent {} -> delete x (insert x xs) $ \case+                    t'@Parent {} -> t == t'+                    _ -> False+              ) ::+                Bool,+      SC.testProperty "validProof (merkleRoot xs) (membershipProof x xs)" $+        \(x :: Data, ys :: SC.NonEmpty Data) ->+          let xs :: UnderTest = scFromList ys+           in validProof (merkleRoot xs) (membershipProof x xs),+      SC.testProperty "valid (fromList xs)" $+        \xs -> valid (scFromList xs :: UnderTest)+    ]++qcProps :: TestTree+qcProps =+  testGroup+    "(checked by QuickCheck)"+    [ QC.testProperty "x `member` foldr insert (insert x xs) ys" $+        \(x :: Data, xs :: QC.NonEmptyList Data, ys :: [Data]) ->+          x `member` foldr insert (insert x (qcFromList xs :: UnderTest)) ys,+      QC.testProperty "x `member` xs ==> digest (singleton x) `lookup` xs = Just x" $+        \(x :: Data, xs :: UnderTest) ->+          x `member` xs QC.==> (digest (singleton x) `lookup` xs == Just x),+      QC.testProperty "x `notMember` delete x (foldr insert (insert x xs) ys)" $+        \(x :: Data, xs :: QC.NonEmptyList Data, ys :: [Data]) ->+          delete x (foldr insert (insert x (qcFromList xs :: UnderTest)) ys) (x `notMember`),+      QC.testProperty "x `notMember` xs ==> digest (singleton x) `lookup` xs = Nothing" $+        \(x :: Data, xs :: UnderTest) ->+          x `notMember` xs QC.==> isNothing (digest (singleton x) `lookup` xs),+      QC.testProperty "delete x (insert x empty) = empty" $+        \x ->+          ( delete x (insert x empty :: UnderTest) $ \case+              Nil {} -> True+              _ -> False+          ) ::+            Bool,+      QC.testProperty "delete x (insert x xs) = delete x xs" $+        \(x :: Data, ys :: QC.NonEmptyList Data) ->+          let xs :: UnderTest = qcFromList ys+           in ( delete x xs $ \case+                  Nil {} -> delete x (insert x xs) null+                  t@Leaf {} -> delete x (insert x xs) $ \case+                    t'@Leaf {} -> t == t'+                    _ -> False+                  t@Parent {} -> delete x (insert x xs) $ \case+                    t'@Parent {} -> t == t'+                    _ -> False+              ) ::+                Bool,+      QC.testProperty "validProof (merkleRoot xs) (membershipProof x xs)" $+        \(x :: Data, ys :: QC.NonEmptyList Data) ->+          let xs :: UnderTest = qcFromList ys+           in validProof (merkleRoot xs) (membershipProof x xs),+      QC.testProperty "valid (fromList xs)" $+        \xs -> valid (qcFromList xs :: UnderTest)+    ]++unitTests :: TestTree+unitTests =+  testGroup+    "Unit tests"+    [ testCase "Test" $+        let xs :: UnderTest = scFromList $ SC.NonEmpty ["data-1", "data-2"]+            x = "data-0"+         in validProof (merkleRoot xs) (membershipProof x xs) @?= True,+      testCase "Insert adds element" $+        (insert "a" $ insert "b" empty :: UnderTest) == insert "b" empty @?= False,+      testCase "Insert is order agnostic" $+        insert "a" (insert "b" (insert "c" empty :: UnderTest)) @?= insert "c" (insert "b" (insert "a" empty)),+      testCase "Empty tree has no member" $+        isExclusionProof (membershipProof "a" (empty :: EmptyUnderTest)) @?= True,+      testCase "Singleton tree has member" $+        isInclusionProof (membershipProof "a" (insert "a" empty :: UnderTest)) @?= True,+      testCase "Singleton tree has no other member" $+        isExclusionProof (membershipProof "b" (insert "a" empty :: UnderTest)) @?= True+    ]++type EmptyUnderTest = CSMT 'Empty SHA256 Data++type UnderTest = CSMT 'NonEmpty SHA256 Data++scFromList :: (ByteArrayAccess a, HashAlgorithm alg) => SC.NonEmpty a -> CompactSparseMerkleTree 'NonEmpty alg a+scFromList (SC.NonEmpty (x : xs)) = fromList (x :| xs)+scFromList _ = error "impossible"++qcFromList :: (ByteArrayAccess a, HashAlgorithm alg) => QC.NonEmptyList a -> CompactSparseMerkleTree 'NonEmpty alg a+qcFromList (QC.NonEmpty (x : xs)) = fromList (x :| xs)+qcFromList _ = error "impossible"