{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module: Data.MerkleLog
-- Copyright: Copyright © 2019 Kadena LLC.
-- License: MIT
-- Maintainer: Lars Kuhtz <lars@kadena.io>
-- Stability: experimental
--
-- Merkle Logs are a append-only data structure. The tree layout in this
-- implementation of Merkle trees is based on the description of Merkle trees in
-- RFC 6962. With this tree layout extending a Merkle tree requires chaining a
-- logarithmic number of nodes at the end of the tree. Unlike RFC 6962 the
-- Merkle trees in this module support the creation of unbalanced MerkleTrees by
-- nesting sub-trees as leafs of Merkle trees. Also, unlike RFC 6962 this module
-- generates fully self-contained inclusion proofs that don't rely on the client
-- being aware of the balancing of the Merkle Tree that was used to generate the
-- proof.
--
-- The API requires the usage of type applications which can be enabled with the
-- following pragma.
--
-- @
-- {-\# LANGUAGE TypeApplications #-}
-- @
--
-- = Example
--
-- @
-- {-\# LANGUAGE TypeApplications #-}
-- {-\# LANGUAGE OverloadedStrings #-}
--
-- import qualified Data.ByteString as B
-- import Crypto.Hash.Algorithms (SHA512t_256)
--
-- inputs = ["a", "b", "c"] :: [B.ByteString]
--
-- -- create tree
-- t = merkleTree @SHA512t_256 inputs
--
-- -- create inclusion proof
-- p = either (error . show) id $ merkleProof 1 (inputs !! 1) t
--
-- -- verify proof
-- runMerkleProof p == merkleRoot t
-- @
--
-- = TODO
--
-- * implement extension of trees (possibly by linking memory chunks of maximal full trees)
--   (how important is this?)
-- * implement consistency proofs
-- * document encodings and hash format
-- * describe tree layout
--
module Data.MerkleLog
(
-- * Merkle Tree
  MerkleTree
, merkleTree
, encodeMerkleTree
, decodeMerkleTree

-- * Merkle Root
, MerkleRoot
, merkleRoot
, encodeMerkleRoot
, decodeMerkleRoot

-- * Merkle Proofs
, MerkleNodeType(..)
, MerkleProof(..)
, MerkleProofSubject(..)
, MerkleProofObject
, encodeMerkleProofObject
, decodeMerkleProofObject
, merkleProof
, merkleProof_
, runMerkleProof

-- * Exceptions
, Expected(..)
, Actual(..)
, MerkleTreeException(..)
, textMessage

-- * Internal

, isEmpty
, emptyMerkleTree
, size
, leafCount
, MerkleHash
, getHash
, merkleLeaf
, merkleNode

) where

import Control.DeepSeq
import Control.Monad
import Control.Monad.Catch

import Crypto.Hash (hash)
import Crypto.Hash.IO

import qualified Data.ByteArray as BA
import Data.ByteArray.Encoding
import qualified Data.ByteString as B
import qualified Data.List.NonEmpty as NE
import qualified Data.Memory.Endian as BA
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Word

import Foreign.Ptr
import Foreign.Storable

import GHC.Generics
import GHC.Stack

import System.IO.Unsafe

-- -------------------------------------------------------------------------- --
-- Exceptions

-- | An expected value.
--
newtype Expected a = Expected a
    deriving (Int -> Expected a -> ShowS
forall a. Show a => Int -> Expected a -> ShowS
forall a. Show a => [Expected a] -> ShowS
forall a. Show a => Expected a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expected a] -> ShowS
$cshowList :: forall a. Show a => [Expected a] -> ShowS
show :: Expected a -> String
$cshow :: forall a. Show a => Expected a -> String
showsPrec :: Int -> Expected a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Expected a -> ShowS
Show, Expected a -> Expected a -> Bool
forall a. Eq a => Expected a -> Expected a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expected a -> Expected a -> Bool
$c/= :: forall a. Eq a => Expected a -> Expected a -> Bool
== :: Expected a -> Expected a -> Bool
$c== :: forall a. Eq a => Expected a -> Expected a -> Bool
Eq, Expected a -> Expected a -> Bool
Expected a -> Expected a -> Ordering
Expected a -> Expected a -> Expected a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Expected a)
forall a. Ord a => Expected a -> Expected a -> Bool
forall a. Ord a => Expected a -> Expected a -> Ordering
forall a. Ord a => Expected a -> Expected a -> Expected a
min :: Expected a -> Expected a -> Expected a
$cmin :: forall a. Ord a => Expected a -> Expected a -> Expected a
max :: Expected a -> Expected a -> Expected a
$cmax :: forall a. Ord a => Expected a -> Expected a -> Expected a
>= :: Expected a -> Expected a -> Bool
$c>= :: forall a. Ord a => Expected a -> Expected a -> Bool
> :: Expected a -> Expected a -> Bool
$c> :: forall a. Ord a => Expected a -> Expected a -> Bool
<= :: Expected a -> Expected a -> Bool
$c<= :: forall a. Ord a => Expected a -> Expected a -> Bool
< :: Expected a -> Expected a -> Bool
$c< :: forall a. Ord a => Expected a -> Expected a -> Bool
compare :: Expected a -> Expected a -> Ordering
$ccompare :: forall a. Ord a => Expected a -> Expected a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Expected a) x -> Expected a
forall a x. Expected a -> Rep (Expected a) x
$cto :: forall a x. Rep (Expected a) x -> Expected a
$cfrom :: forall a x. Expected a -> Rep (Expected a) x
Generic)
    deriving anyclass (forall a. NFData a => Expected a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Expected a -> ()
$crnf :: forall a. NFData a => Expected a -> ()
NFData)

-- | An actual value.
--
newtype Actual a = Actual a
    deriving (Int -> Actual a -> ShowS
forall a. Show a => Int -> Actual a -> ShowS
forall a. Show a => [Actual a] -> ShowS
forall a. Show a => Actual a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Actual a] -> ShowS
$cshowList :: forall a. Show a => [Actual a] -> ShowS
show :: Actual a -> String
$cshow :: forall a. Show a => Actual a -> String
showsPrec :: Int -> Actual a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Actual a -> ShowS
Show, Actual a -> Actual a -> Bool
forall a. Eq a => Actual a -> Actual a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Actual a -> Actual a -> Bool
$c/= :: forall a. Eq a => Actual a -> Actual a -> Bool
== :: Actual a -> Actual a -> Bool
$c== :: forall a. Eq a => Actual a -> Actual a -> Bool
Eq, Actual a -> Actual a -> Bool
Actual a -> Actual a -> Ordering
Actual a -> Actual a -> Actual a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Actual a)
forall a. Ord a => Actual a -> Actual a -> Bool
forall a. Ord a => Actual a -> Actual a -> Ordering
forall a. Ord a => Actual a -> Actual a -> Actual a
min :: Actual a -> Actual a -> Actual a
$cmin :: forall a. Ord a => Actual a -> Actual a -> Actual a
max :: Actual a -> Actual a -> Actual a
$cmax :: forall a. Ord a => Actual a -> Actual a -> Actual a
>= :: Actual a -> Actual a -> Bool
$c>= :: forall a. Ord a => Actual a -> Actual a -> Bool
> :: Actual a -> Actual a -> Bool
$c> :: forall a. Ord a => Actual a -> Actual a -> Bool
<= :: Actual a -> Actual a -> Bool
$c<= :: forall a. Ord a => Actual a -> Actual a -> Bool
< :: Actual a -> Actual a -> Bool
$c< :: forall a. Ord a => Actual a -> Actual a -> Bool
compare :: Actual a -> Actual a -> Ordering
$ccompare :: forall a. Ord a => Actual a -> Actual a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Actual a) x -> Actual a
forall a x. Actual a -> Rep (Actual a) x
$cto :: forall a x. Rep (Actual a) x -> Actual a
$cfrom :: forall a x. Actual a -> Rep (Actual a) x
Generic)
    deriving anyclass (forall a. NFData a => Actual a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Actual a -> ()
$crnf :: forall a. NFData a => Actual a -> ()
NFData)

-- | Format a text messages that compares an 'Expected' with an 'Actual' value.
--
expectedMessage :: Show a => Expected a -> Actual a -> T.Text
expectedMessage :: forall a. Show a => Expected a -> Actual a -> Text
expectedMessage (Expected a
e) (Actual a
a)
    = Text
"Expected: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, IsString b) => a -> b
sshow a
e forall a. Semigroup a => a -> a -> a
<> Text
", Actual: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, IsString b) => a -> b
sshow a
a

-- | Exceptions that are thrown by functions in "Data.MerkleLog". All functions
-- that throw exceptions can be called as pure functions in `Either
-- SomeException`.
--
data MerkleTreeException
    = EncodingSizeException T.Text (Expected Int) (Actual Int)
    | EncodingSizeConstraintException T.Text (Expected T.Text) (Actual Int)
    | IndexOutOfBoundsException T.Text (Expected (Int, Int)) (Actual Int)
    | InputNotInTreeException T.Text Int B.ByteString
    | MerkleRootNotInTreeException T.Text Int B.ByteString
    | InvalidProofObjectException T.Text
    deriving (MerkleTreeException -> MerkleTreeException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleTreeException -> MerkleTreeException -> Bool
$c/= :: MerkleTreeException -> MerkleTreeException -> Bool
== :: MerkleTreeException -> MerkleTreeException -> Bool
$c== :: MerkleTreeException -> MerkleTreeException -> Bool
Eq, forall x. Rep MerkleTreeException x -> MerkleTreeException
forall x. MerkleTreeException -> Rep MerkleTreeException x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MerkleTreeException x -> MerkleTreeException
$cfrom :: forall x. MerkleTreeException -> Rep MerkleTreeException x
Generic)
    deriving anyclass (MerkleTreeException -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleTreeException -> ()
$crnf :: MerkleTreeException -> ()
NFData)

instance Exception MerkleTreeException where
    displayException :: MerkleTreeException -> String
displayException = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. MerkleTreeException -> Text
textMessage

instance Show MerkleTreeException where
    show :: MerkleTreeException -> String
show = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. MerkleTreeException -> Text
textMessage

-- | Display 'MerkleTreeException' values as text messages.
--
textMessage :: MerkleTreeException -> T.Text
textMessage :: MerkleTreeException -> Text
textMessage (EncodingSizeException Text
ty Expected Int
e Actual Int
a)
    = Text
"Failed to decode " forall a. Semigroup a => a -> a -> a
<> Text
ty forall a. Semigroup a => a -> a -> a
<> Text
" because the input is of wrong size"
    forall a. Semigroup a => a -> a -> a
<> Text
". " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => Expected a -> Actual a -> Text
expectedMessage Expected Int
e Actual Int
a
textMessage (EncodingSizeConstraintException Text
ty (Expected Text
e) (Actual Int
a))
    = Text
"Failed to decode " forall a. Semigroup a => a -> a -> a
<> Text
ty forall a. Semigroup a => a -> a -> a
<> Text
" because the input is of wrong size"
    forall a. Semigroup a => a -> a -> a
<> Text
". " forall a. Semigroup a => a -> a -> a
<> Text
"Expected: " forall a. Semigroup a => a -> a -> a
<> Text
e
    forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> Text
"Actual: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, IsString b) => a -> b
sshow Int
a
textMessage (IndexOutOfBoundsException Text
ty (Expected (Int, Int)
e) (Actual Int
a))
    = Text
"Index out of bounds"
    forall a. Semigroup a => a -> a -> a
<> Text
". " forall a. Semigroup a => a -> a -> a
<> Text
ty
    forall a. Semigroup a => a -> a -> a
<> Text
". " forall a. Semigroup a => a -> a -> a
<> Text
"Expected: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, IsString b) => a -> b
sshow (Int, Int)
e
    forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> Text
"Actual: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, IsString b) => a -> b
sshow Int
a
textMessage (InputNotInTreeException Text
t Int
i ByteString
b)
    = Text
"Item not in tree"
    forall a. Semigroup a => a -> a -> a
<> Text
". " forall a. Semigroup a => a -> a -> a
<> Text
t
    forall a. Semigroup a => a -> a -> a
<> Text
". Position: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, IsString b) => a -> b
sshow Int
i
    forall a. Semigroup a => a -> a -> a
<> Text
". Input (b64): " forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.take Int
1024 (forall a. ByteArrayAccess a => a -> Text
b64 ByteString
b)
textMessage (MerkleRootNotInTreeException Text
t Int
i ByteString
b)
    = Text
"Item not in tree"
    forall a. Semigroup a => a -> a -> a
<> Text
". " forall a. Semigroup a => a -> a -> a
<> Text
t
    forall a. Semigroup a => a -> a -> a
<> Text
". Position: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, IsString b) => a -> b
sshow Int
i
    forall a. Semigroup a => a -> a -> a
<> Text
". Input (b64): " forall a. Semigroup a => a -> a -> a
<> forall a. ByteArrayAccess a => a -> Text
b64 ByteString
b
textMessage (InvalidProofObjectException Text
t)
    = Text
"Invalid ProofObject: " forall a. Semigroup a => a -> a -> a
<> Text
t

inputNotInTreeException
    :: T.Text
    -> Int
    -> MerkleNodeType a B.ByteString
    -> MerkleTreeException
inputNotInTreeException :: forall a.
Text -> Int -> MerkleNodeType a ByteString -> MerkleTreeException
inputNotInTreeException Text
t Int
pos (TreeNode MerkleRoot a
r)
    = Text -> Int -> ByteString -> MerkleTreeException
MerkleRootNotInTreeException Text
t Int
pos forall a b. (a -> b) -> a -> b
$ forall b a. ByteArray b => MerkleRoot a -> b
encodeMerkleRoot MerkleRoot a
r
inputNotInTreeException Text
t Int
pos (InputNode ByteString
b)
    = Text -> Int -> ByteString -> MerkleTreeException
InputNotInTreeException Text
t Int
pos ByteString
b

-- -------------------------------------------------------------------------- --
-- Hashes

-- | Internal type to represent hash values.
--
newtype MerkleHash a = MerkleHash BA.Bytes
    deriving (MerkleHash a -> MerkleHash a -> Bool
forall a. MerkleHash a -> MerkleHash a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleHash a -> MerkleHash a -> Bool
$c/= :: forall a. MerkleHash a -> MerkleHash a -> Bool
== :: MerkleHash a -> MerkleHash a -> Bool
$c== :: forall a. MerkleHash a -> MerkleHash a -> Bool
Eq, MerkleHash a -> MerkleHash a -> Bool
MerkleHash a -> MerkleHash a -> Ordering
MerkleHash a -> MerkleHash a -> MerkleHash a
forall a. Eq (MerkleHash a)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. MerkleHash a -> MerkleHash a -> Bool
forall a. MerkleHash a -> MerkleHash a -> Ordering
forall a. MerkleHash a -> MerkleHash a -> MerkleHash a
min :: MerkleHash a -> MerkleHash a -> MerkleHash a
$cmin :: forall a. MerkleHash a -> MerkleHash a -> MerkleHash a
max :: MerkleHash a -> MerkleHash a -> MerkleHash a
$cmax :: forall a. MerkleHash a -> MerkleHash a -> MerkleHash a
>= :: MerkleHash a -> MerkleHash a -> Bool
$c>= :: forall a. MerkleHash a -> MerkleHash a -> Bool
> :: MerkleHash a -> MerkleHash a -> Bool
$c> :: forall a. MerkleHash a -> MerkleHash a -> Bool
<= :: MerkleHash a -> MerkleHash a -> Bool
$c<= :: forall a. MerkleHash a -> MerkleHash a -> Bool
< :: MerkleHash a -> MerkleHash a -> Bool
$c< :: forall a. MerkleHash a -> MerkleHash a -> Bool
compare :: MerkleHash a -> MerkleHash a -> Ordering
$ccompare :: forall a. MerkleHash a -> MerkleHash a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MerkleHash a) x -> MerkleHash a
forall a x. MerkleHash a -> Rep (MerkleHash a) x
$cto :: forall a x. Rep (MerkleHash a) x -> MerkleHash a
$cfrom :: forall a x. MerkleHash a -> Rep (MerkleHash a) x
Generic)
    deriving newtype (MerkleHash a -> ()
forall a. MerkleHash a -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleHash a -> ()
$crnf :: forall a. MerkleHash a -> ()
NFData, MerkleHash a -> Int
forall a. MerkleHash a -> Int
forall p. MerkleHash a -> Ptr p -> IO ()
forall ba.
(ba -> Int)
-> (forall p a. ba -> (Ptr p -> IO a) -> IO a)
-> (forall p. ba -> Ptr p -> IO ())
-> ByteArrayAccess ba
forall a p. MerkleHash a -> Ptr p -> IO ()
forall p a. MerkleHash a -> (Ptr p -> IO a) -> IO a
forall a p a. MerkleHash a -> (Ptr p -> IO a) -> IO a
copyByteArrayToPtr :: forall p. MerkleHash a -> Ptr p -> IO ()
$ccopyByteArrayToPtr :: forall a p. MerkleHash a -> Ptr p -> IO ()
withByteArray :: forall p a. MerkleHash a -> (Ptr p -> IO a) -> IO a
$cwithByteArray :: forall a p a. MerkleHash a -> (Ptr p -> IO a) -> IO a
length :: MerkleHash a -> Int
$clength :: forall a. MerkleHash a -> Int
BA.ByteArrayAccess)

instance Show (MerkleHash a) where
    show :: MerkleHash a -> String
show = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ByteArrayAccess a => a -> [Word8]
BA.unpack @BA.Bytes
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded
    {-# INLINEABLE show #-}

-- | The size of 'MerkleHash' values in bytes.
--
hashSize :: forall a c . HashAlgorithm a => Num c => c
hashSize :: forall a c. (HashAlgorithm a, Num c) => c
hashSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. HashAlgorithm a => a -> Int
hashDigestSize @a forall a. HasCallStack => a
undefined
    -- the 'undefined' argument is a type proxy that isn't evaluated
{-# INLINE hashSize #-}

-- | Decode a 'MerkleHash' from bytes.
--
decodeMerkleHash
    :: forall a b m
    . MonadThrow m
    => HashAlgorithm a
    => BA.ByteArrayAccess b
    => b
    -> m (MerkleHash a)
decodeMerkleHash :: forall a b (m :: * -> *).
(MonadThrow m, HashAlgorithm a, ByteArrayAccess b) =>
b -> m (MerkleHash a)
decodeMerkleHash b
b
    | forall ba. ByteArrayAccess ba => ba -> Int
BA.length b
b forall a. Eq a => a -> a -> Bool
/= forall a c. (HashAlgorithm a, Num c) => c
hashSize @a = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM MerkleTreeException
e
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Bytes -> MerkleHash a
MerkleHash forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert b
b
  where
    e :: MerkleTreeException
e = Text -> Expected Int -> Actual Int -> MerkleTreeException
EncodingSizeException Text
"MerkleHash"
        (forall a. a -> Expected a
Expected (forall a c. (HashAlgorithm a, Num c) => c
hashSize @a @Int))
        (forall a. a -> Actual a
Actual (forall ba. ByteArrayAccess ba => ba -> Int
BA.length b
b))
{-# INLINE decodeMerkleHash #-}

-- -------------------------------------------------------------------------- --
-- Merkle Tree Nodes

leafTag :: BA.ByteArray a => a
leafTag :: forall a. ByteArray a => a
leafTag = forall a. ByteArray a => Word8 -> a
BA.singleton Word8
0
{-# INLINE leafTag #-}

nodeTag :: BA.ByteArray a => a
nodeTag :: forall a. ByteArray a => a
nodeTag = forall a. ByteArray a => Word8 -> a
BA.singleton Word8
1
{-# INLINE nodeTag #-}

-- | Compute hash for a leaf node in a Merkle tree.
--
merkleLeaf
    :: forall a b
    . HashAlgorithm a
    => BA.ByteArrayAccess b
    => b
    -> MerkleHash a
merkleLeaf :: forall a b.
(HashAlgorithm a, ByteArrayAccess b) =>
b -> MerkleHash a
merkleLeaf !b
bytes = forall a. Bytes -> MerkleHash a
MerkleHash forall a b. (a -> b) -> a -> b
$ forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
BA.allocAndFreeze (forall a c. (HashAlgorithm a, Num c) => c
hashSize @a) forall a b. (a -> b) -> a -> b
$ \Ptr (MerkleHash a)
ptr -> do
    !MutableContext a
ctx <- forall alg. HashAlgorithm alg => IO (MutableContext alg)
hashMutableInit @a
    forall a b.
(HashAlgorithm a, ByteArrayAccess b) =>
MutableContext a -> b -> Ptr (MerkleHash a) -> IO ()
merkleLeafPtr MutableContext a
ctx b
bytes Ptr (MerkleHash a)
ptr

-- | Compute hash for an inner node of a Merkle tree.
--
merkleNode
    :: forall a
    . HashAlgorithm a
    => MerkleHash a
    -> MerkleHash a
    -> MerkleRoot a
merkleNode :: forall a.
HashAlgorithm a =>
MerkleHash a -> MerkleHash a -> MerkleRoot a
merkleNode !MerkleHash a
a !MerkleHash a
b = forall a. MerkleHash a -> MerkleRoot a
MerkleRoot forall a b. (a -> b) -> a -> b
$ forall a. Bytes -> MerkleHash a
MerkleHash forall a b. (a -> b) -> a -> b
$ forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
BA.allocAndFreeze (forall a c. (HashAlgorithm a, Num c) => c
hashSize @a) forall a b. (a -> b) -> a -> b
$ \Ptr (MerkleHash a)
ptr -> do
    !MutableContext a
ctx <- forall alg. HashAlgorithm alg => IO (MutableContext alg)
hashMutableInit @a
    forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray MerkleHash a
a forall a b. (a -> b) -> a -> b
$ \Ptr (MerkleHash a)
aptr ->
        forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray MerkleHash a
b forall a b. (a -> b) -> a -> b
$ \Ptr (MerkleHash a)
bptr ->
            forall a.
HashAlgorithm a =>
MutableContext a
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> IO ()
merkleNodePtr MutableContext a
ctx Ptr (MerkleHash a)
aptr Ptr (MerkleHash a)
bptr Ptr (MerkleHash a)
ptr

-- | Compute hash for inner node of a Merkle tree.
--
merkleNodePtr
    :: forall a
    . HashAlgorithm a
    => MutableContext a
    -> Ptr (MerkleHash a)
    -> Ptr (MerkleHash a)
    -> Ptr (MerkleHash a)
    -> IO ()
merkleNodePtr :: forall a.
HashAlgorithm a =>
MutableContext a
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> IO ()
merkleNodePtr !MutableContext a
ctx !Ptr (MerkleHash a)
a !Ptr (MerkleHash a)
b !Ptr (MerkleHash a)
r = do
    forall a. HashAlgorithm a => MutableContext a -> IO ()
hashMutableReset MutableContext a
ctx
    forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
MutableContext a -> ba -> IO ()
hashMutableUpdate MutableContext a
ctx (forall a. ByteArray a => a
nodeTag @BA.Bytes)
    forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray MutableContext a
ctx forall a b. (a -> b) -> a -> b
$ \Ptr (Context a)
ctxPtr -> do
        forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate @a Ptr (Context a)
ctxPtr (forall a b. Ptr a -> Ptr b
castPtr Ptr (MerkleHash a)
a) (forall a c. (HashAlgorithm a, Num c) => c
hashSize @a)
        forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate Ptr (Context a)
ctxPtr (forall a b. Ptr a -> Ptr b
castPtr Ptr (MerkleHash a)
b) (forall a c. (HashAlgorithm a, Num c) => c
hashSize @a)
        forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr (Digest a) -> IO ()
hashInternalFinalize Ptr (Context a)
ctxPtr (forall a b. Ptr a -> Ptr b
castPtr Ptr (MerkleHash a)
r)

-- | Compute hash for a leaf node in a Merkle tree.
--
merkleLeafPtr
    :: forall a b
    . HashAlgorithm a
    => BA.ByteArrayAccess b
    => MutableContext a
    -> b
    -> Ptr (MerkleHash a)
    -> IO ()
merkleLeafPtr :: forall a b.
(HashAlgorithm a, ByteArrayAccess b) =>
MutableContext a -> b -> Ptr (MerkleHash a) -> IO ()
merkleLeafPtr !MutableContext a
ctx !b
b !Ptr (MerkleHash a)
r = do
    forall a. HashAlgorithm a => MutableContext a -> IO ()
hashMutableReset MutableContext a
ctx
    forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
MutableContext a -> ba -> IO ()
hashMutableUpdate MutableContext a
ctx (forall a. ByteArray a => a
leafTag @BA.Bytes)
    forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
MutableContext a -> ba -> IO ()
hashMutableUpdate MutableContext a
ctx b
b
    forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray MutableContext a
ctx forall a b. (a -> b) -> a -> b
$ \Ptr (Context a)
ctxPtr ->
        forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr (Digest a) -> IO ()
hashInternalFinalize @a Ptr (Context a)
ctxPtr (forall a b. Ptr a -> Ptr b
castPtr Ptr (MerkleHash a)
r)

-- -------------------------------------------------------------------------- --
-- Merkle Tree
--
-- Using unsafe operations in the implementation is fine, since proof testing of
-- Merkle proof validation provides robust assurance that the data in the
-- underlying memory is correct to the bit level, i.e. it's very unlikely that a
-- bug would slip through the unit tests.
--

-- | The Type of leafs nodes in a Merkle tree. A node is either an input value
-- or a root of another nested Merkle tree.
--
data MerkleNodeType a b
    = TreeNode (MerkleRoot a)
    | InputNode b
    deriving (Int -> MerkleNodeType a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. Show b => Int -> MerkleNodeType a b -> ShowS
forall a b. Show b => [MerkleNodeType a b] -> ShowS
forall a b. Show b => MerkleNodeType a b -> String
showList :: [MerkleNodeType a b] -> ShowS
$cshowList :: forall a b. Show b => [MerkleNodeType a b] -> ShowS
show :: MerkleNodeType a b -> String
$cshow :: forall a b. Show b => MerkleNodeType a b -> String
showsPrec :: Int -> MerkleNodeType a b -> ShowS
$cshowsPrec :: forall a b. Show b => Int -> MerkleNodeType a b -> ShowS
Show, MerkleNodeType a b -> MerkleNodeType a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
Eq b =>
MerkleNodeType a b -> MerkleNodeType a b -> Bool
/= :: MerkleNodeType a b -> MerkleNodeType a b -> Bool
$c/= :: forall a b.
Eq b =>
MerkleNodeType a b -> MerkleNodeType a b -> Bool
== :: MerkleNodeType a b -> MerkleNodeType a b -> Bool
$c== :: forall a b.
Eq b =>
MerkleNodeType a b -> MerkleNodeType a b -> Bool
Eq, MerkleNodeType a b -> MerkleNodeType a b -> Bool
MerkleNodeType a b -> MerkleNodeType a b -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a} {b}. Ord b => Eq (MerkleNodeType a b)
forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> Bool
forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> Ordering
forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> MerkleNodeType a b
min :: MerkleNodeType a b -> MerkleNodeType a b -> MerkleNodeType a b
$cmin :: forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> MerkleNodeType a b
max :: MerkleNodeType a b -> MerkleNodeType a b -> MerkleNodeType a b
$cmax :: forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> MerkleNodeType a b
>= :: MerkleNodeType a b -> MerkleNodeType a b -> Bool
$c>= :: forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> Bool
> :: MerkleNodeType a b -> MerkleNodeType a b -> Bool
$c> :: forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> Bool
<= :: MerkleNodeType a b -> MerkleNodeType a b -> Bool
$c<= :: forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> Bool
< :: MerkleNodeType a b -> MerkleNodeType a b -> Bool
$c< :: forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> Bool
compare :: MerkleNodeType a b -> MerkleNodeType a b -> Ordering
$ccompare :: forall a b.
Ord b =>
MerkleNodeType a b -> MerkleNodeType a b -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (MerkleNodeType a b) x -> MerkleNodeType a b
forall a b x. MerkleNodeType a b -> Rep (MerkleNodeType a b) x
$cto :: forall a b x. Rep (MerkleNodeType a b) x -> MerkleNodeType a b
$cfrom :: forall a b x. MerkleNodeType a b -> Rep (MerkleNodeType a b) x
Generic, forall a b. a -> MerkleNodeType a b -> MerkleNodeType a a
forall a b. (a -> b) -> MerkleNodeType a a -> MerkleNodeType a b
forall a a b. a -> MerkleNodeType a b -> MerkleNodeType a a
forall a a b. (a -> b) -> MerkleNodeType a a -> MerkleNodeType a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MerkleNodeType a b -> MerkleNodeType a a
$c<$ :: forall a a b. a -> MerkleNodeType a b -> MerkleNodeType a a
fmap :: forall a b. (a -> b) -> MerkleNodeType a a -> MerkleNodeType a b
$cfmap :: forall a a b. (a -> b) -> MerkleNodeType a a -> MerkleNodeType a b
Functor)
    deriving anyclass (forall a. (a -> ()) -> NFData a
forall a b. NFData b => MerkleNodeType a b -> ()
rnf :: MerkleNodeType a b -> ()
$crnf :: forall a b. NFData b => MerkleNodeType a b -> ()
NFData)

-- | Binary Merkle Tree.
--
-- A Merkle Tree is only an index. It doesn't store any data but only hashes of
-- the data that is referenced in the tree.
--
newtype MerkleTree a = MerkleTree BA.Bytes
    deriving (MerkleTree a -> MerkleTree a -> Bool
forall a. MerkleTree a -> MerkleTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleTree a -> MerkleTree a -> Bool
$c/= :: forall a. MerkleTree a -> MerkleTree a -> Bool
== :: MerkleTree a -> MerkleTree a -> Bool
$c== :: forall a. MerkleTree a -> MerkleTree a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MerkleTree a) x -> MerkleTree a
forall a x. MerkleTree a -> Rep (MerkleTree a) x
$cto :: forall a x. Rep (MerkleTree a) x -> MerkleTree a
$cfrom :: forall a x. MerkleTree a -> Rep (MerkleTree a) x
Generic)
    deriving newtype (MerkleTree a -> ()
forall a. MerkleTree a -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleTree a -> ()
$crnf :: forall a. MerkleTree a -> ()
NFData, MerkleTree a -> Int
forall a. MerkleTree a -> Int
forall p. MerkleTree a -> Ptr p -> IO ()
forall ba.
(ba -> Int)
-> (forall p a. ba -> (Ptr p -> IO a) -> IO a)
-> (forall p. ba -> Ptr p -> IO ())
-> ByteArrayAccess ba
forall a p. MerkleTree a -> Ptr p -> IO ()
forall p a. MerkleTree a -> (Ptr p -> IO a) -> IO a
forall a p a. MerkleTree a -> (Ptr p -> IO a) -> IO a
copyByteArrayToPtr :: forall p. MerkleTree a -> Ptr p -> IO ()
$ccopyByteArrayToPtr :: forall a p. MerkleTree a -> Ptr p -> IO ()
withByteArray :: forall p a. MerkleTree a -> (Ptr p -> IO a) -> IO a
$cwithByteArray :: forall a p a. MerkleTree a -> (Ptr p -> IO a) -> IO a
length :: MerkleTree a -> Int
$clength :: forall a. MerkleTree a -> Int
BA.ByteArrayAccess)

instance Show (MerkleTree a) where
    show :: MerkleTree a -> String
show = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ByteArrayAccess a => a -> [Word8]
BA.unpack @BA.Bytes
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded
    {-# INLINEABLE show #-}

-- | Merkle Tree as described in RFC 6962, but with a configurable hash function
-- and support for nested Merkle trees.
--
-- The Merkle tree for the empty input log is the hash of the empty string.
--
-- TODO: The length of the list is forced before the algorithm starts processing
-- the items. Either demand a strict structure (e.g. vector or array) or
-- allocate tree memory dynamically while traversing the log structure.
--
merkleTree
    :: forall a b
    . HasCallStack
    => HashAlgorithm a
    => BA.ByteArrayAccess b
    => [MerkleNodeType a b]
    -> MerkleTree a
merkleTree :: forall a b.
(HasCallStack, HashAlgorithm a, ByteArrayAccess b) =>
[MerkleNodeType a b] -> MerkleTree a
merkleTree [] = forall a. Bytes -> MerkleTree a
MerkleTree forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall a b. (a -> b) -> a -> b
$ forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash @_ @a (forall a. Monoid a => a
mempty @B.ByteString)
merkleTree ![MerkleNodeType a b]
items = forall a. Bytes -> MerkleTree a
MerkleTree forall a b. (a -> b) -> a -> b
$ forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
BA.allocAndFreeze (Int
tsize forall a. Num a => a -> a -> a
* forall a c. (HashAlgorithm a, Num c) => c
hashSize @a) forall a b. (a -> b) -> a -> b
$ \Ptr (MerkleHash a)
ptr -> do

    !MutableContext a
ctx <- forall alg. HashAlgorithm alg => IO (MutableContext alg)
hashMutableInit @a

    -- TODO compare performance with explicit construction
    let
        -- | This uses logarithmic stack space
        --
        go
            :: Ptr (MerkleHash a)
                -- ^ ptr into output tree
            -> [MerkleNodeType a b]
                -- ^ input log
            -> [(Int, Ptr (MerkleHash a))]
                -- stack of tree hight and ptr into tree
            -> IO ()

        -- Create new inner node from stack tree positions on stack
        --
        go :: Ptr (MerkleHash a)
-> [MerkleNodeType a b] -> [(Int, Ptr (MerkleHash a))] -> IO ()
go !Ptr (MerkleHash a)
i [MerkleNodeType a b]
t ((!Int
a, !Ptr (MerkleHash a)
ia) : (!Int
b, !Ptr (MerkleHash a)
ib) : [(Int, Ptr (MerkleHash a))]
s) | Int
a forall a. Eq a => a -> a -> Bool
== Int
b = do
            forall a.
HashAlgorithm a =>
MutableContext a
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> IO ()
merkleNodePtr MutableContext a
ctx Ptr (MerkleHash a)
ib Ptr (MerkleHash a)
ia Ptr (MerkleHash a)
i
            Ptr (MerkleHash a)
-> [MerkleNodeType a b] -> [(Int, Ptr (MerkleHash a))] -> IO ()
go (Ptr (MerkleHash a)
i forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
hs) [MerkleNodeType a b]
t ((forall a. Enum a => a -> a
succ Int
a, Ptr (MerkleHash a)
i) forall a. a -> [a] -> [a]
: [(Int, Ptr (MerkleHash a))]
s)

        -- Create new leaf node on the stack
        --
        go !Ptr (MerkleHash a)
i (InputNode b
h : [MerkleNodeType a b]
t) ![(Int, Ptr (MerkleHash a))]
s = do
            forall a b.
(HashAlgorithm a, ByteArrayAccess b) =>
MutableContext a -> b -> Ptr (MerkleHash a) -> IO ()
merkleLeafPtr MutableContext a
ctx b
h Ptr (MerkleHash a)
i
            Ptr (MerkleHash a)
-> [MerkleNodeType a b] -> [(Int, Ptr (MerkleHash a))] -> IO ()
go (Ptr (MerkleHash a)
i forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
hs) [MerkleNodeType a b]
t ((Int
0, Ptr (MerkleHash a)
i) forall a. a -> [a] -> [a]
: [(Int, Ptr (MerkleHash a))]
s)

        go !Ptr (MerkleHash a)
i (TreeNode MerkleRoot a
h : [MerkleNodeType a b]
t) ![(Int, Ptr (MerkleHash a))]
s = do
            forall ba p. ByteArrayAccess ba => ba -> Ptr p -> IO ()
BA.copyByteArrayToPtr MerkleRoot a
h Ptr (MerkleHash a)
i
            Ptr (MerkleHash a)
-> [MerkleNodeType a b] -> [(Int, Ptr (MerkleHash a))] -> IO ()
go (Ptr (MerkleHash a)
i forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
hs) [MerkleNodeType a b]
t ((Int
0, Ptr (MerkleHash a)
i) forall a. a -> [a] -> [a]
: [(Int, Ptr (MerkleHash a))]
s)

        -- When all inputs are consumed, include remaining nodes on the
        -- stack as unbalanced subtree
        --
        go !Ptr (MerkleHash a)
i [] ((!Int
a, !Ptr (MerkleHash a)
ia) : (!Int
_, !Ptr (MerkleHash a)
ib) : [(Int, Ptr (MerkleHash a))]
s) = do
            forall a.
HashAlgorithm a =>
MutableContext a
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> IO ()
merkleNodePtr MutableContext a
ctx Ptr (MerkleHash a)
ib Ptr (MerkleHash a)
ia Ptr (MerkleHash a)
i
            Ptr (MerkleHash a)
-> [MerkleNodeType a b] -> [(Int, Ptr (MerkleHash a))] -> IO ()
go (Ptr (MerkleHash a)
i forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
hs) [] ((forall a. Enum a => a -> a
succ Int
a, Ptr (MerkleHash a)
i) forall a. a -> [a] -> [a]
: [(Int, Ptr (MerkleHash a))]
s)

        go Ptr (MerkleHash a)
_ [] [(Int, Ptr (MerkleHash a))
_] = forall (m :: * -> *) a. Monad m => a -> m a
return ()

        go Ptr (MerkleHash a)
_ [] [] = forall a. HasCallStack => String -> a
error String
"code invariant violation"

    Ptr (MerkleHash a)
-> [MerkleNodeType a b] -> [(Int, Ptr (MerkleHash a))] -> IO ()
go Ptr (MerkleHash a)
ptr [MerkleNodeType a b]
items []

  where
    !isize :: Int
isize = forall (t :: * -> *) a. Foldable t => t a -> Int
length [MerkleNodeType a b]
items
    !tsize :: Int
tsize = Int
isize forall a. Num a => a -> a -> a
+ (Int
isize forall a. Num a => a -> a -> a
- Int
1)
    !hs :: Int
hs = forall a c. (HashAlgorithm a, Num c) => c
hashSize @a

-- | Test a Merkle tree is the tree of the empty log.
--
isEmpty :: forall a . HashAlgorithm a => MerkleTree a -> Bool
isEmpty :: forall a. HashAlgorithm a => MerkleTree a -> Bool
isEmpty = forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
BA.constEq (forall a. HashAlgorithm a => MerkleTree a
emptyMerkleTree @a)
{-# INLINE isEmpty #-}

-- | The Merkle tree of the empty log. RFC 6962 specifies that this is the hash
-- of the empty string.
--
emptyMerkleTree :: forall a . HashAlgorithm a => MerkleTree a
emptyMerkleTree :: forall a. HashAlgorithm a => MerkleTree a
emptyMerkleTree = forall a b.
(HasCallStack, HashAlgorithm a, ByteArrayAccess b) =>
[MerkleNodeType a b] -> MerkleTree a
merkleTree @a ([] @(MerkleNodeType a B.ByteString))
{-# INLINEABLE emptyMerkleTree #-}

-- | Binary encoding of a Merkle tree.
--
encodeMerkleTree :: BA.ByteArray b => MerkleTree a -> b
encodeMerkleTree :: forall b a. ByteArray b => MerkleTree a -> b
encodeMerkleTree = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
{-# INLINE encodeMerkleTree #-}

-- | The number of nodes (including leafs) in a Merkle tree.
--
size :: forall a . HashAlgorithm a => MerkleTree a -> Int
size :: forall a. HashAlgorithm a => MerkleTree a -> Int
size MerkleTree a
t = forall ba. ByteArrayAccess ba => ba -> Int
BA.length MerkleTree a
t forall a. Integral a => a -> a -> a
`div` forall a c. (HashAlgorithm a, Num c) => c
hashSize @a
{-# INLINE size #-}

-- | Decode are Merkle tree from a binary representation.
--
decodeMerkleTree
    :: forall a b m
    . MonadThrow m
    => HashAlgorithm a
    => BA.ByteArrayAccess b
    => b
    -> m (MerkleTree a)
decodeMerkleTree :: forall a b (m :: * -> *).
(MonadThrow m, HashAlgorithm a, ByteArrayAccess b) =>
b -> m (MerkleTree a)
decodeMerkleTree b
b
    | forall ba. ByteArrayAccess ba => ba -> Int
BA.length b
b forall a. Integral a => a -> a -> a
`mod` forall a c. (HashAlgorithm a, Num c) => c
hashSize @a forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Bytes -> MerkleTree a
MerkleTree forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert b
b
    | Bool
otherwise = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> Expected Text -> Actual Int -> MerkleTreeException
EncodingSizeConstraintException
        Text
"MerkleTree"
        (forall a. a -> Expected a
Expected forall a b. (a -> b) -> a -> b
$ Text
"multiple of " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, IsString b) => a -> b
sshow (forall a c. (HashAlgorithm a, Num c) => c
hashSize @a @Int))
        (forall a. a -> Actual a
Actual forall a b. (a -> b) -> a -> b
$ forall ba. ByteArrayAccess ba => ba -> Int
BA.length b
b)
{-# INLINE decodeMerkleTree #-}

-- -------------------------------------------------------------------------- --
-- Merkle Root

-- | The root of a Merkle tree.
--
newtype MerkleRoot a = MerkleRoot (MerkleHash a)
    deriving (MerkleRoot a -> MerkleRoot a -> Bool
forall a. MerkleRoot a -> MerkleRoot a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleRoot a -> MerkleRoot a -> Bool
$c/= :: forall a. MerkleRoot a -> MerkleRoot a -> Bool
== :: MerkleRoot a -> MerkleRoot a -> Bool
$c== :: forall a. MerkleRoot a -> MerkleRoot a -> Bool
Eq, MerkleRoot a -> MerkleRoot a -> Bool
MerkleRoot a -> MerkleRoot a -> Ordering
MerkleRoot a -> MerkleRoot a -> MerkleRoot a
forall a. Eq (MerkleRoot a)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. MerkleRoot a -> MerkleRoot a -> Bool
forall a. MerkleRoot a -> MerkleRoot a -> Ordering
forall a. MerkleRoot a -> MerkleRoot a -> MerkleRoot a
min :: MerkleRoot a -> MerkleRoot a -> MerkleRoot a
$cmin :: forall a. MerkleRoot a -> MerkleRoot a -> MerkleRoot a
max :: MerkleRoot a -> MerkleRoot a -> MerkleRoot a
$cmax :: forall a. MerkleRoot a -> MerkleRoot a -> MerkleRoot a
>= :: MerkleRoot a -> MerkleRoot a -> Bool
$c>= :: forall a. MerkleRoot a -> MerkleRoot a -> Bool
> :: MerkleRoot a -> MerkleRoot a -> Bool
$c> :: forall a. MerkleRoot a -> MerkleRoot a -> Bool
<= :: MerkleRoot a -> MerkleRoot a -> Bool
$c<= :: forall a. MerkleRoot a -> MerkleRoot a -> Bool
< :: MerkleRoot a -> MerkleRoot a -> Bool
$c< :: forall a. MerkleRoot a -> MerkleRoot a -> Bool
compare :: MerkleRoot a -> MerkleRoot a -> Ordering
$ccompare :: forall a. MerkleRoot a -> MerkleRoot a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MerkleRoot a) x -> MerkleRoot a
forall a x. MerkleRoot a -> Rep (MerkleRoot a) x
$cto :: forall a x. Rep (MerkleRoot a) x -> MerkleRoot a
$cfrom :: forall a x. MerkleRoot a -> Rep (MerkleRoot a) x
Generic)
    deriving newtype (Int -> MerkleRoot a -> ShowS
[MerkleRoot a] -> ShowS
MerkleRoot a -> String
forall a. Int -> MerkleRoot a -> ShowS
forall a. [MerkleRoot a] -> ShowS
forall a. MerkleRoot a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MerkleRoot a] -> ShowS
$cshowList :: forall a. [MerkleRoot a] -> ShowS
show :: MerkleRoot a -> String
$cshow :: forall a. MerkleRoot a -> String
showsPrec :: Int -> MerkleRoot a -> ShowS
$cshowsPrec :: forall a. Int -> MerkleRoot a -> ShowS
Show, MerkleRoot a -> ()
forall a. MerkleRoot a -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleRoot a -> ()
$crnf :: forall a. MerkleRoot a -> ()
NFData, MerkleRoot a -> Int
forall a. MerkleRoot a -> Int
forall p. MerkleRoot a -> Ptr p -> IO ()
forall ba.
(ba -> Int)
-> (forall p a. ba -> (Ptr p -> IO a) -> IO a)
-> (forall p. ba -> Ptr p -> IO ())
-> ByteArrayAccess ba
forall a p. MerkleRoot a -> Ptr p -> IO ()
forall p a. MerkleRoot a -> (Ptr p -> IO a) -> IO a
forall a p a. MerkleRoot a -> (Ptr p -> IO a) -> IO a
copyByteArrayToPtr :: forall p. MerkleRoot a -> Ptr p -> IO ()
$ccopyByteArrayToPtr :: forall a p. MerkleRoot a -> Ptr p -> IO ()
withByteArray :: forall p a. MerkleRoot a -> (Ptr p -> IO a) -> IO a
$cwithByteArray :: forall a p a. MerkleRoot a -> (Ptr p -> IO a) -> IO a
length :: MerkleRoot a -> Int
$clength :: forall a. MerkleRoot a -> Int
BA.ByteArrayAccess)

-- | Get the root of Merkle tree.
--
merkleRoot :: forall a . HashAlgorithm a => MerkleTree a -> MerkleRoot a
merkleRoot :: forall a. HashAlgorithm a => MerkleTree a -> MerkleRoot a
merkleRoot MerkleTree a
t = forall a. MerkleHash a -> MerkleRoot a
MerkleRoot forall a b. (a -> b) -> a -> b
$ forall a. HashAlgorithm a => MerkleTree a -> Int -> MerkleHash a
getHash MerkleTree a
t (forall a. HashAlgorithm a => MerkleTree a -> Int
size MerkleTree a
t forall a. Num a => a -> a -> a
- Int
1)
{-# INLINE merkleRoot #-}

-- | Encode a Merkle tree root into binary format.
--
encodeMerkleRoot :: BA.ByteArray b => MerkleRoot a -> b
encodeMerkleRoot :: forall b a. ByteArray b => MerkleRoot a -> b
encodeMerkleRoot = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
{-# INLINE encodeMerkleRoot #-}

-- | Decode a Merkle tree root from a binary representation.
--
decodeMerkleRoot
    :: MonadThrow m
    => HashAlgorithm a
    => BA.ByteArrayAccess b
    => b
    -> m (MerkleRoot a)
decodeMerkleRoot :: forall (m :: * -> *) a b.
(MonadThrow m, HashAlgorithm a, ByteArrayAccess b) =>
b -> m (MerkleRoot a)
decodeMerkleRoot = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. MerkleHash a -> MerkleRoot a
MerkleRoot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b (m :: * -> *).
(MonadThrow m, HashAlgorithm a, ByteArrayAccess b) =>
b -> m (MerkleHash a)
decodeMerkleHash
{-# INLINE decodeMerkleRoot #-}

-- -------------------------------------------------------------------------- --
-- Proof Object

-- | Opaque proof object.
--
newtype MerkleProofObject a = MerkleProofObject BA.Bytes
    deriving (MerkleProofObject a -> MerkleProofObject a -> Bool
forall a. MerkleProofObject a -> MerkleProofObject a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleProofObject a -> MerkleProofObject a -> Bool
$c/= :: forall a. MerkleProofObject a -> MerkleProofObject a -> Bool
== :: MerkleProofObject a -> MerkleProofObject a -> Bool
$c== :: forall a. MerkleProofObject a -> MerkleProofObject a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MerkleProofObject a) x -> MerkleProofObject a
forall a x. MerkleProofObject a -> Rep (MerkleProofObject a) x
$cto :: forall a x. Rep (MerkleProofObject a) x -> MerkleProofObject a
$cfrom :: forall a x. MerkleProofObject a -> Rep (MerkleProofObject a) x
Generic)
    deriving anyclass (forall a. MerkleProofObject a -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleProofObject a -> ()
$crnf :: forall a. MerkleProofObject a -> ()
NFData)
    deriving newtype (MerkleProofObject a -> Int
forall a. MerkleProofObject a -> Int
forall p. MerkleProofObject a -> Ptr p -> IO ()
forall ba.
(ba -> Int)
-> (forall p a. ba -> (Ptr p -> IO a) -> IO a)
-> (forall p. ba -> Ptr p -> IO ())
-> ByteArrayAccess ba
forall a p. MerkleProofObject a -> Ptr p -> IO ()
forall p a. MerkleProofObject a -> (Ptr p -> IO a) -> IO a
forall a p a. MerkleProofObject a -> (Ptr p -> IO a) -> IO a
copyByteArrayToPtr :: forall p. MerkleProofObject a -> Ptr p -> IO ()
$ccopyByteArrayToPtr :: forall a p. MerkleProofObject a -> Ptr p -> IO ()
withByteArray :: forall p a. MerkleProofObject a -> (Ptr p -> IO a) -> IO a
$cwithByteArray :: forall a p a. MerkleProofObject a -> (Ptr p -> IO a) -> IO a
length :: MerkleProofObject a -> Int
$clength :: forall a. MerkleProofObject a -> Int
BA.ByteArrayAccess)

instance Show (MerkleProofObject a) where
    show :: MerkleProofObject a -> String
show = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ByteArrayAccess a => a -> [Word8]
BA.unpack @BA.Bytes
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase @_ @BA.Bytes Base
Base64URLUnpadded
    {-# INLINEABLE show #-}

-- | Encode a Merkle proof object into binary format.
--
-- This copies the bytes of the underlying byte array. The encoded object
-- doesn't reference the 'MerkleProofObject'
--
encodeMerkleProofObject :: BA.ByteArray b => MerkleProofObject a -> b
encodeMerkleProofObject :: forall b a. ByteArray b => MerkleProofObject a -> b
encodeMerkleProofObject = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
{-# INLINE encodeMerkleProofObject #-}

-- | Encode a Merkle proof object from a binary representation.
--
-- This copies the original bytes and doesn't keep a reference to the input
-- bytes.
--
decodeMerkleProofObject
    :: forall a b m
    . MonadThrow m
    => HashAlgorithm a
    => BA.ByteArrayAccess b
    => b
    -> m (MerkleProofObject a)
decodeMerkleProofObject :: forall a b (m :: * -> *).
(MonadThrow m, HashAlgorithm a, ByteArrayAccess b) =>
b -> m (MerkleProofObject a)
decodeMerkleProofObject b
bytes
    | forall ba. ByteArrayAccess ba => ba -> Int
BA.length b
bytes forall a. Ord a => a -> a -> Bool
< Int
12 = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
        forall a b. (a -> b) -> a -> b
$ Text -> Expected Text -> Actual Int -> MerkleTreeException
EncodingSizeConstraintException
            Text
"MerkleProofObject"
            (forall a. a -> Expected a
Expected Text
"larger than 12")
            (forall a. a -> Actual a
Actual forall a b. (a -> b) -> a -> b
$ forall ba. ByteArrayAccess ba => ba -> Int
BA.length b
bytes)
    | forall ba. ByteArrayAccess ba => ba -> Int
BA.length b
bytes forall a. Eq a => a -> a -> Bool
/= forall a. HashAlgorithm a => Int -> Int
proofObjectSizeInBytes @a Int
stepCount = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
        forall a b. (a -> b) -> a -> b
$ Text -> Expected Int -> Actual Int -> MerkleTreeException
EncodingSizeException
            Text
"MerkleProofObject"
            (forall a. a -> Expected a
Expected forall a b. (a -> b) -> a -> b
$ forall a. HashAlgorithm a => Int -> Int
proofObjectSizeInBytes @a Int
stepCount)
            (forall a. a -> Actual a
Actual forall a b. (a -> b) -> a -> b
$ forall ba. ByteArrayAccess ba => ba -> Int
BA.length b
bytes)
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Bytes -> MerkleProofObject a
MerkleProofObject forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert b
bytes
  where
    stepCount :: Int
stepCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. ByteSwap a => BE a -> a
BA.fromBE forall a b. (a -> b) -> a -> b
$ forall a b. (Storable a, ByteArrayAccess b) => b -> a
peekBA @(BA.BE Word32) b
bytes

stepSize :: forall a . HashAlgorithm a => Int
stepSize :: forall a. HashAlgorithm a => Int
stepSize = forall a c. (HashAlgorithm a, Num c) => c
hashSize @a forall a. Num a => a -> a -> a
+ Int
1
{-# INLINE stepSize #-}

proofObjectSizeInBytes :: forall a . HashAlgorithm a => Int -> Int
proofObjectSizeInBytes :: forall a. HashAlgorithm a => Int -> Int
proofObjectSizeInBytes Int
stepCount = forall a. HashAlgorithm a => Int
stepSize @a forall a. Num a => a -> a -> a
* Int
stepCount forall a. Num a => a -> a -> a
+ Int
12
{-# INLINE proofObjectSizeInBytes #-}

-- -------------------------------------------------------------------------- --
-- Proof Subject

-- | The subject for which inclusion is proven.
--
newtype MerkleProofSubject a = MerkleProofSubject
    { forall a. MerkleProofSubject a -> MerkleNodeType a ByteString
_getMerkleProofSubject :: (MerkleNodeType a B.ByteString) }
    deriving (Int -> MerkleProofSubject a -> ShowS
forall a. Int -> MerkleProofSubject a -> ShowS
forall a. [MerkleProofSubject a] -> ShowS
forall a. MerkleProofSubject a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MerkleProofSubject a] -> ShowS
$cshowList :: forall a. [MerkleProofSubject a] -> ShowS
show :: MerkleProofSubject a -> String
$cshow :: forall a. MerkleProofSubject a -> String
showsPrec :: Int -> MerkleProofSubject a -> ShowS
$cshowsPrec :: forall a. Int -> MerkleProofSubject a -> ShowS
Show, MerkleProofSubject a -> MerkleProofSubject a -> Bool
forall a. MerkleProofSubject a -> MerkleProofSubject a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleProofSubject a -> MerkleProofSubject a -> Bool
$c/= :: forall a. MerkleProofSubject a -> MerkleProofSubject a -> Bool
== :: MerkleProofSubject a -> MerkleProofSubject a -> Bool
$c== :: forall a. MerkleProofSubject a -> MerkleProofSubject a -> Bool
Eq, MerkleProofSubject a -> MerkleProofSubject a -> Bool
MerkleProofSubject a -> MerkleProofSubject a -> Ordering
MerkleProofSubject a
-> MerkleProofSubject a -> MerkleProofSubject a
forall a. Eq (MerkleProofSubject a)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. MerkleProofSubject a -> MerkleProofSubject a -> Bool
forall a. MerkleProofSubject a -> MerkleProofSubject a -> Ordering
forall a.
MerkleProofSubject a
-> MerkleProofSubject a -> MerkleProofSubject a
min :: MerkleProofSubject a
-> MerkleProofSubject a -> MerkleProofSubject a
$cmin :: forall a.
MerkleProofSubject a
-> MerkleProofSubject a -> MerkleProofSubject a
max :: MerkleProofSubject a
-> MerkleProofSubject a -> MerkleProofSubject a
$cmax :: forall a.
MerkleProofSubject a
-> MerkleProofSubject a -> MerkleProofSubject a
>= :: MerkleProofSubject a -> MerkleProofSubject a -> Bool
$c>= :: forall a. MerkleProofSubject a -> MerkleProofSubject a -> Bool
> :: MerkleProofSubject a -> MerkleProofSubject a -> Bool
$c> :: forall a. MerkleProofSubject a -> MerkleProofSubject a -> Bool
<= :: MerkleProofSubject a -> MerkleProofSubject a -> Bool
$c<= :: forall a. MerkleProofSubject a -> MerkleProofSubject a -> Bool
< :: MerkleProofSubject a -> MerkleProofSubject a -> Bool
$c< :: forall a. MerkleProofSubject a -> MerkleProofSubject a -> Bool
compare :: MerkleProofSubject a -> MerkleProofSubject a -> Ordering
$ccompare :: forall a. MerkleProofSubject a -> MerkleProofSubject a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MerkleProofSubject a) x -> MerkleProofSubject a
forall a x. MerkleProofSubject a -> Rep (MerkleProofSubject a) x
$cto :: forall a x. Rep (MerkleProofSubject a) x -> MerkleProofSubject a
$cfrom :: forall a x. MerkleProofSubject a -> Rep (MerkleProofSubject a) x
Generic)
    deriving anyclass (forall a. MerkleProofSubject a -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleProofSubject a -> ()
$crnf :: forall a. MerkleProofSubject a -> ()
NFData)

-- -------------------------------------------------------------------------- --
-- Merkle Proof

-- | Merkle Inclusion Proof. In RFC 6962 this is called an audit proof. The
-- proof in this module are not compatible with RFC 6962. They support proving
-- inclusion of subtrees and proof for unbalanced trees of unknown size.
--
-- The proof is self-contained. It is independent of the concrete implementation
-- of the Merkle tree. This type works with any binary Merkle tree type and
-- doesn't make any assumptions about the balancing of the tree.
--
-- The proof includes the subject of the proof (for which inclusion is proven)
-- as a plaintext bytestring. The proof does not include the root hash of the
-- Merkle tree, because the proof is only meaningful if the root is available
-- from a trusted source. Including it into the proof would thus be redundant or
-- even misleading.
--
-- A more compact encoding would use the first bit of each hash to encode the
-- side, but that would require to alter the hash computation. We also could
-- pack the sides into a bit array. However, the total number of bytes for the
-- sides will be most likely less than two hashes, so the overhead is small and
-- doesn't justify more clever encodings.
--
data MerkleProof a = MerkleProof
    { forall a. MerkleProof a -> MerkleProofSubject a
_merkleProofSubject :: !(MerkleProofSubject a)
    , forall a. MerkleProof a -> MerkleProofObject a
_merkleProofObject :: !(MerkleProofObject a)
    }
    deriving (Int -> MerkleProof a -> ShowS
forall a. Int -> MerkleProof a -> ShowS
forall a. [MerkleProof a] -> ShowS
forall a. MerkleProof a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MerkleProof a] -> ShowS
$cshowList :: forall a. [MerkleProof a] -> ShowS
show :: MerkleProof a -> String
$cshow :: forall a. MerkleProof a -> String
showsPrec :: Int -> MerkleProof a -> ShowS
$cshowsPrec :: forall a. Int -> MerkleProof a -> ShowS
Show, MerkleProof a -> MerkleProof a -> Bool
forall a. MerkleProof a -> MerkleProof a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleProof a -> MerkleProof a -> Bool
$c/= :: forall a. MerkleProof a -> MerkleProof a -> Bool
== :: MerkleProof a -> MerkleProof a -> Bool
$c== :: forall a. MerkleProof a -> MerkleProof a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MerkleProof a) x -> MerkleProof a
forall a x. MerkleProof a -> Rep (MerkleProof a) x
$cto :: forall a x. Rep (MerkleProof a) x -> MerkleProof a
$cfrom :: forall a x. MerkleProof a -> Rep (MerkleProof a) x
Generic)
    deriving anyclass (forall a. MerkleProof a -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleProof a -> ()
$crnf :: forall a. MerkleProof a -> ()
NFData)

-- | Construct a self-contained Merkle inclusion proof.
--
merkleProof
    :: forall a m
    . MonadThrow m
    => HashAlgorithm a
    => MerkleNodeType a B.ByteString
    -> Int
    -> MerkleTree a
    -> m (MerkleProof a)
merkleProof :: forall a (m :: * -> *).
(MonadThrow m, HashAlgorithm a) =>
MerkleNodeType a ByteString
-> Int -> MerkleTree a -> m (MerkleProof a)
merkleProof MerkleNodeType a ByteString
a Int
pos MerkleTree a
t
    | Int
pos forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
pos forall a. Ord a => a -> a -> Bool
>= forall a. HashAlgorithm a => MerkleTree a -> Int
leafCount MerkleTree a
t = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> Expected (Int, Int) -> Actual Int -> MerkleTreeException
IndexOutOfBoundsException
        Text
"merkleProof"
        (forall a. a -> Expected a
Expected (Int
0,forall a. HashAlgorithm a => MerkleTree a -> Int
leafCount MerkleTree a
t forall a. Num a => a -> a -> a
- Int
1))
        (forall a. a -> Actual a
Actual Int
pos)
    | Bool -> Bool
not (forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
BA.constEq (forall a. HashAlgorithm a => MerkleTree a -> Int -> View Bytes
view MerkleTree a
t Int
tpos) (forall {b}. ByteArrayAccess b => MerkleNodeType a b -> MerkleHash a
inputHash MerkleNodeType a ByteString
a)) = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
        forall a b. (a -> b) -> a -> b
$ forall a.
Text -> Int -> MerkleNodeType a ByteString -> MerkleTreeException
inputNotInTreeException Text
"merkleProof" Int
pos MerkleNodeType a ByteString
a
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MerkleProof
        { _merkleProofSubject :: MerkleProofSubject a
_merkleProofSubject = forall a. MerkleNodeType a ByteString -> MerkleProofSubject a
MerkleProofSubject MerkleNodeType a ByteString
a
        , _merkleProofObject :: MerkleProofObject a
_merkleProofObject = forall a. Bytes -> MerkleProofObject a
MerkleProofObject Bytes
go
        }
  where
    inputHash :: MerkleNodeType a b -> MerkleHash a
inputHash (InputNode b
bytes) = forall a b.
(HashAlgorithm a, ByteArrayAccess b) =>
b -> MerkleHash a
merkleLeaf @a b
bytes
    inputHash (TreeNode (MerkleRoot MerkleHash a
bytes)) = MerkleHash a
bytes

    (Int
tpos, [(Side, Int)]
path) = Int -> Int -> (Int, [(Side, Int)])
proofPath Int
pos (forall a. HashAlgorithm a => MerkleTree a -> Int
leafCount MerkleTree a
t)
    go :: Bytes
go = forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
BA.allocAndFreeze (forall a. HashAlgorithm a => Int -> Int
proofObjectSizeInBytes @a (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Side, Int)]
path)) forall a b. (a -> b) -> a -> b
$ \Ptr (BE Word32)
ptr -> do
        -- encode number of proof stepts in 4 bytes
        forall a. (ByteSwap a, Storable a) => Ptr (BE a) -> a -> IO ()
pokeBE @Word32 Ptr (BE Word32)
ptr forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Side, Int)]
path

        -- encode index of subject in input order in 8 bytes
        forall a. (ByteSwap a, Storable a) => Ptr (BE a) -> a -> IO ()
pokeBE @Word64 (Ptr (BE Word32)
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pos)

        -- encode path
        let pathPtr :: Ptr b
pathPtr = Ptr (BE Word32)
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
12
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Side, Int)]
path forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. HashAlgorithm a => Int
stepSize @a) ..]) forall a b. (a -> b) -> a -> b
$ \((Side
s, Int
i), Int
x) -> do
            forall a. Storable a => Ptr a -> a -> IO ()
poke (forall {b}. Ptr b
pathPtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
x) (Side -> Word8
sideWord8 Side
s)
            forall ba p. ByteArrayAccess ba => ba -> Ptr p -> IO ()
BA.copyByteArrayToPtr (forall a. HashAlgorithm a => MerkleTree a -> Int -> View Bytes
view MerkleTree a
t Int
i) (forall {b}. Ptr b
pathPtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Enum a => a -> a
succ Int
x)

-- | Construct a Merkle proof for a proof subject in a nested sub-tree.
--
-- FIXME: make this function more efficient by implementing it more directly.
--
merkleProof_
    :: forall a m
    . MonadThrow m
    => HashAlgorithm a
    => MerkleNodeType a B.ByteString
        -- ^ The proof subject
    -> NE.NonEmpty (Int, MerkleTree a)
        -- ^ The proof components
    -> m (MerkleProof a)
merkleProof_ :: forall a (m :: * -> *).
(MonadThrow m, HashAlgorithm a) =>
MerkleNodeType a ByteString
-> NonEmpty (Int, MerkleTree a) -> m (MerkleProof a)
merkleProof_ MerkleNodeType a ByteString
a NonEmpty (Int, MerkleTree a)
l
    = forall a.
MerkleProofSubject a -> MerkleProofObject a -> MerkleProof a
MerkleProof (forall a. MerkleNodeType a ByteString -> MerkleProofSubject a
MerkleProofSubject MerkleNodeType a ByteString
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bytes -> MerkleProofObject a
MerkleProofObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {bout} {bin} {b}.
(ByteArray bout, ByteArray bin, ByteSwap b, Num b) =>
[(b, bin)] -> bout
assemble forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {a}.
(MonadThrow m, HashAlgorithm a) =>
MerkleNodeType a ByteString
-> [(Int, MerkleTree a)] -> m [(Word32, Bytes)]
go MerkleNodeType a ByteString
a (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Int, MerkleTree a)
l)
  where
    go :: MerkleNodeType a ByteString
-> [(Int, MerkleTree a)] -> m [(Word32, Bytes)]
go MerkleNodeType a ByteString
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go MerkleNodeType a ByteString
sub ((Int
pos, MerkleTree a
tree) : [(Int, MerkleTree a)]
t) = do
        -- create sub-proof
        MerkleProof (MerkleProofSubject MerkleNodeType a ByteString
_) (MerkleProofObject Bytes
o) <- forall a (m :: * -> *).
(MonadThrow m, HashAlgorithm a) =>
MerkleNodeType a ByteString
-> Int -> MerkleTree a -> m (MerkleProof a)
merkleProof MerkleNodeType a ByteString
sub Int
pos MerkleTree a
tree
        -- collect step counts and stripped proof objects
        (:) (forall {b}. ByteArray b => b -> (Word32, b)
strip Bytes
o) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MerkleNodeType a ByteString
-> [(Int, MerkleTree a)] -> m [(Word32, Bytes)]
go (forall a b. MerkleRoot a -> MerkleNodeType a b
TreeNode forall a b. (a -> b) -> a -> b
$ forall a. HashAlgorithm a => MerkleTree a -> MerkleRoot a
merkleRoot MerkleTree a
tree) [(Int, MerkleTree a)]
t

    -- strip path length and subject position from proof object
    strip :: b -> (Word32, b)
strip b
o = (forall a b. (ByteSwap a, Storable a, ByteArrayAccess b) => b -> a
peekBeBA b
o :: Word32, forall bs. ByteArray bs => Int -> bs -> bs
BA.drop Int
12 b
o)
    assemble :: [(b, bin)] -> bout
assemble [(b, bin)]
ps =
        let ([b]
s, [bin]
os) = forall a b. [(a, b)] -> ([a], [b])
unzip [(b, bin)]
ps
        in forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
[bin] -> bout
BA.concat
            -- inject length of overall path
            forall a b. (a -> b) -> a -> b
$ forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
BA.allocAndFreeze Int
4 (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (ByteSwap a, Storable a) => Ptr (BE a) -> a -> IO ()
pokeBE forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [b]
s)
            -- inject position of proof subject
            forall a. a -> [a] -> [a]
: forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
BA.allocAndFreeze Int
8 (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. (ByteSwap a, Storable a) => Ptr (BE a) -> a -> IO ()
pokeBE @Word64) forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty (Int, MerkleTree a)
l)
            forall a. a -> [a] -> [a]
: [bin]
os

proofPath
    :: Int
        -- ^ Position in log
    -> Int
        -- ^ Size of log
    -> (Int, [(Side, Int)])
        -- ^ The tree position of the target node and tree positions and
        -- directions of the audit proof.
proofPath :: Int -> Int -> (Int, [(Side, Int)])
proofPath Int
b Int
c = Int -> Int -> Int -> Int -> [(Side, Int)] -> (Int, [(Side, Int)])
go Int
0 Int
0 Int
b Int
c []
  where
    go :: Int -> Int -> Int -> Int -> [(Side, Int)] -> (Int, [(Side, Int)])
go Int
_ !Int
treeOff Int
_ Int
1 ![(Side, Int)]
acc = (Int
treeOff, [(Side, Int)]
acc)
    go !Int
logOff !Int
treeOff !Int
m !Int
n ![(Side, Int)]
acc
        | Int
m forall a. Ord a => a -> a -> Bool
< Int
k = Int -> Int -> Int -> Int -> [(Side, Int)] -> (Int, [(Side, Int)])
go Int
logOff Int
treeOff Int
m Int
k forall a b. (a -> b) -> a -> b
$ (Side
R, Int
treeOff forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
* Int
n forall a. Num a => a -> a -> a
- Int
3) forall a. a -> [a] -> [a]
: [(Side, Int)]
acc
        | Bool
otherwise = Int -> Int -> Int -> Int -> [(Side, Int)] -> (Int, [(Side, Int)])
go (Int
logOff forall a. Num a => a -> a -> a
+ Int
k) (Int
treeOff forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
* Int
k forall a. Num a => a -> a -> a
- Int
1) (Int
m forall a. Num a => a -> a -> a
- Int
k) (Int
n forall a. Num a => a -> a -> a
- Int
k)
            forall a b. (a -> b) -> a -> b
$ (Side
L, Int
treeOff forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
* Int
k forall a. Num a => a -> a -> a
- Int
2) forall a. a -> [a] -> [a]
: [(Side, Int)]
acc
      where
        k :: Int
k = Int -> Int
k2 Int
n

-- | Execute an inclusion proof. The result of the execution is a Merkle root
-- that must be compared to the trusted root of the Merkle tree.
--
runMerkleProof :: forall a . HashAlgorithm a => MerkleProof a -> MerkleRoot a
runMerkleProof :: forall a. HashAlgorithm a => MerkleProof a -> MerkleRoot a
runMerkleProof MerkleProof a
p = forall a. MerkleHash a -> MerkleRoot a
MerkleRoot forall a b. (a -> b) -> a -> b
$ forall a. Bytes -> MerkleHash a
MerkleHash forall a b. (a -> b) -> a -> b
$ forall a b c d.
(HashAlgorithm a, ByteArrayAccess b, ByteArrayAccess c,
 ByteArray d) =>
MerkleNodeType a b -> c -> d
runMerkleProofInternal @a MerkleNodeType a ByteString
subj Bytes
obj
  where
    MerkleProofSubject MerkleNodeType a ByteString
subj = forall a. MerkleProof a -> MerkleProofSubject a
_merkleProofSubject MerkleProof a
p
    MerkleProofObject Bytes
obj = forall a. MerkleProof a -> MerkleProofObject a
_merkleProofObject MerkleProof a
p

runMerkleProofInternal
    :: forall a b c d
    . HashAlgorithm a
    => BA.ByteArrayAccess b
    => BA.ByteArrayAccess c
    => BA.ByteArray d
    => MerkleNodeType a b
        -- ^ proof subject
    -> c
        -- ^ proof object
    -> d
runMerkleProofInternal :: forall a b c d.
(HashAlgorithm a, ByteArrayAccess b, ByteArrayAccess c,
 ByteArray d) =>
MerkleNodeType a b -> c -> d
runMerkleProofInternal MerkleNodeType a b
subj c
obj = forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
BA.allocAndFreeze (forall a c. (HashAlgorithm a, Num c) => c
hashSize @a) forall a b. (a -> b) -> a -> b
$ \Ptr (MerkleHash a)
ptr -> do
    MutableContext a
ctx <- forall alg. HashAlgorithm alg => IO (MutableContext alg)
hashMutableInit @a
    case MerkleNodeType a b
subj of
        InputNode b
x -> forall a b.
(HashAlgorithm a, ByteArrayAccess b) =>
MutableContext a -> b -> Ptr (MerkleHash a) -> IO ()
merkleLeafPtr MutableContext a
ctx b
x Ptr (MerkleHash a)
ptr
        TreeNode MerkleRoot a
x -> forall ba p. ByteArrayAccess ba => ba -> Ptr p -> IO ()
BA.copyByteArrayToPtr MerkleRoot a
x Ptr (MerkleHash a)
ptr
    forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray c
obj forall a b. (a -> b) -> a -> b
$ \Ptr (BE Word32)
objPtr -> do
        Int
stepCount <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (ByteSwap a, Storable a) => Ptr (BE a) -> IO a
peekBE @Word32 Ptr (BE Word32)
objPtr
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
stepCount forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \(Int
i :: Int) -> do
            let off :: Int
off = Int
12 forall a. Num a => a -> a -> a
+ Int
i forall a. Num a => a -> a -> a
* forall a. HashAlgorithm a => Int
stepSize @a
            forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff @Word8 Ptr (BE Word32)
objPtr Int
off forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Word8
0x00 -> forall a.
HashAlgorithm a =>
MutableContext a
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> IO ()
merkleNodePtr MutableContext a
ctx (Ptr (BE Word32)
objPtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Enum a => a -> a
succ Int
off) Ptr (MerkleHash a)
ptr Ptr (MerkleHash a)
ptr
                Word8
0x01 -> forall a.
HashAlgorithm a =>
MutableContext a
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> Ptr (MerkleHash a)
-> IO ()
merkleNodePtr MutableContext a
ctx Ptr (MerkleHash a)
ptr (Ptr (BE Word32)
objPtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Enum a => a -> a
succ Int
off) Ptr (MerkleHash a)
ptr
                Word8
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> MerkleTreeException
InvalidProofObjectException Text
"runMerkleProofInternal"

-- -------------------------------------------------------------------------- --
-- Utils

k2 :: Int -> Int
k2 :: Int -> Int
k2 Int
i = Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ forall a b. (RealFrac a, Integral b) => a -> b
floor @Double @Int (forall a. Floating a => a -> a -> a
logBase Double
2 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i forall a. Num a => a -> a -> a
- Double
1)
{-# INLINE k2 #-}

data Side = L | R
    deriving (Int -> Side -> ShowS
[Side] -> ShowS
Side -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Side] -> ShowS
$cshowList :: [Side] -> ShowS
show :: Side -> String
$cshow :: Side -> String
showsPrec :: Int -> Side -> ShowS
$cshowsPrec :: Int -> Side -> ShowS
Show, Side -> Side -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Side -> Side -> Bool
$c/= :: Side -> Side -> Bool
== :: Side -> Side -> Bool
$c== :: Side -> Side -> Bool
Eq)

sideWord8 :: Side -> Word8
sideWord8 :: Side -> Word8
sideWord8 Side
L = Word8
0x00
sideWord8 Side
R = Word8
0x01
{-# INLINE sideWord8 #-}

view :: forall a . HashAlgorithm a => MerkleTree a -> Int -> BA.View BA.Bytes
view :: forall a. HashAlgorithm a => MerkleTree a -> Int -> View Bytes
view (MerkleTree Bytes
v) Int
i = forall bytes.
ByteArrayAccess bytes =>
bytes -> Int -> Int -> View bytes
BA.view Bytes
v (Int
i forall a. Num a => a -> a -> a
* forall a c. (HashAlgorithm a, Num c) => c
hashSize @a) (forall a c. (HashAlgorithm a, Num c) => c
hashSize @a)
{-# INLINE view #-}

-- | Get the hash of a node in the Merkle tree.
--
getHash :: HashAlgorithm a => MerkleTree a -> Int -> MerkleHash a
getHash :: forall a. HashAlgorithm a => MerkleTree a -> Int -> MerkleHash a
getHash MerkleTree a
t = forall a. Bytes -> MerkleHash a
MerkleHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => MerkleTree a -> Int -> View Bytes
view MerkleTree a
t
{-# INLINE getHash #-}

-- | Get the number of leafs in a Merkle tree.
--
leafCount :: HashAlgorithm a => MerkleTree a -> Int
leafCount :: forall a. HashAlgorithm a => MerkleTree a -> Int
leafCount MerkleTree a
t
    | forall a. HashAlgorithm a => MerkleTree a -> Bool
isEmpty MerkleTree a
t = Int
0
    | Bool
otherwise = Int
1 forall a. Num a => a -> a -> a
+ forall a. HashAlgorithm a => MerkleTree a -> Int
size MerkleTree a
t forall a. Integral a => a -> a -> a
`div` Int
2
{-# INLINE leafCount #-}

peekBE :: forall a . BA.ByteSwap a => Storable a => Ptr (BA.BE a) -> IO a
peekBE :: forall a. (ByteSwap a, Storable a) => Ptr (BE a) -> IO a
peekBE Ptr (BE a)
ptr = forall a. ByteSwap a => BE a -> a
BA.fromBE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek @(BA.BE a) Ptr (BE a)
ptr
{-# INLINE peekBE #-}

pokeBE :: forall a . BA.ByteSwap a => Storable a => Ptr (BA.BE a) -> a -> IO ()
pokeBE :: forall a. (ByteSwap a, Storable a) => Ptr (BE a) -> a -> IO ()
pokeBE Ptr (BE a)
ptr = forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (BE a)
ptr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ByteSwap a => a -> BE a
BA.toBE @a
{-# INLINE pokeBE #-}

peekBA :: forall a b . Storable a => BA.ByteArrayAccess b => b -> a
peekBA :: forall a b. (Storable a, ByteArrayAccess b) => b -> a
peekBA b
bytes = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray b
bytes (forall a. Storable a => Ptr a -> IO a
peek @a)
{-# INLINE peekBA #-}

peekBeBA :: forall a b . BA.ByteSwap a => Storable a => BA.ByteArrayAccess b => b -> a
peekBeBA :: forall a b. (ByteSwap a, Storable a, ByteArrayAccess b) => b -> a
peekBeBA = forall a. ByteSwap a => BE a -> a
BA.fromBE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, ByteArrayAccess b) => b -> a
peekBA @(BA.BE a)
{-# INLINE peekBeBA #-}

{- Useful for debugging
hex :: BA.ByteArrayAccess a => a -> String
hex = fmap (toEnum . fromEnum)
    . BA.unpack @BA.Bytes
    . convertToBase Base16
-}

b64 :: BA.ByteArrayAccess a => a -> T.Text
b64 :: forall a. ByteArrayAccess a => a -> Text
b64 = ByteString -> Text
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded
{-# INLINE b64 #-}

sshow :: Show a => IsString b => a -> b
sshow :: forall a b. (Show a, IsString b) => a -> b
sshow = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
{-# INLINE sshow #-}