{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Merkle tree implementation.
--
-- See <https://tools.ietf.org/html/rfc6962>.
module Cardano.Chain.Common.Merkle
  ( -- * MerkleRoot
    MerkleRoot (..),

    -- * MerkleTree
    MerkleTree (..),
    mtRoot,
    mkMerkleTree,
    mkMerkleTreeDecoded,

    -- * MerkleNode
    MerkleNode (..),
    mkBranch,
    mkLeaf,
    mkLeafDecoded,
  )
where

-- Cardano.Prelude has its own Rube Goldberg variant of 'Foldable' which we do not
-- want. It would be great if we could write
--   import           Cardano.Prelude hiding (toList, foldMap)
-- but HLint insists that this is not OK because toList and foldMap are never
-- used unqualified. The hiding in fact makes it clearer for the human reader
-- what's going on.

import Cardano.Binary
  ( Annotated (..),
    FromCBOR (..),
    Raw,
    ToCBOR (..),
    serializeBuilder,
  )
import Cardano.Crypto (Hash, hashDecoded, hashRaw, hashToBytes)
import Cardano.Prelude
import Data.Aeson (ToJSON)
import Data.ByteString.Builder (Builder, byteString, word8)
import qualified Data.ByteString.Builder.Extra as Builder
import qualified Data.ByteString.Lazy as LBS
import Data.Coerce (coerce)
import qualified Data.Foldable as Foldable
import Formatting.Buildable (Buildable (..))
import NoThunks.Class (NoThunks (..))
import qualified Prelude

--------------------------------------------------------------------------------
-- MerkleRoot
--------------------------------------------------------------------------------

-- | Data type for root of Merkle tree
newtype MerkleRoot a = MerkleRoot
  { -- | returns root 'Hash' of Merkle Tree
    MerkleRoot a -> Hash Raw
getMerkleRoot :: Hash Raw
  }
  deriving (Int -> MerkleRoot a -> ShowS
[MerkleRoot a] -> ShowS
MerkleRoot a -> String
(Int -> MerkleRoot a -> ShowS)
-> (MerkleRoot a -> String)
-> ([MerkleRoot a] -> ShowS)
-> Show (MerkleRoot a)
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 -> MerkleRoot a -> Bool
(MerkleRoot a -> MerkleRoot a -> Bool)
-> (MerkleRoot a -> MerkleRoot a -> Bool) -> Eq (MerkleRoot a)
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, Eq (MerkleRoot a)
Eq (MerkleRoot a)
-> (MerkleRoot a -> MerkleRoot a -> Ordering)
-> (MerkleRoot a -> MerkleRoot a -> Bool)
-> (MerkleRoot a -> MerkleRoot a -> Bool)
-> (MerkleRoot a -> MerkleRoot a -> Bool)
-> (MerkleRoot a -> MerkleRoot a -> Bool)
-> (MerkleRoot a -> MerkleRoot a -> MerkleRoot a)
-> (MerkleRoot a -> MerkleRoot a -> MerkleRoot a)
-> Ord (MerkleRoot a)
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
$cp1Ord :: forall a. Eq (MerkleRoot a)
Ord, (forall x. MerkleRoot a -> Rep (MerkleRoot a) x)
-> (forall x. Rep (MerkleRoot a) x -> MerkleRoot a)
-> Generic (MerkleRoot a)
forall x. Rep (MerkleRoot a) x -> MerkleRoot a
forall x. MerkleRoot a -> Rep (MerkleRoot a) x
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 anyclass (MerkleRoot a -> ()
(MerkleRoot a -> ()) -> NFData (MerkleRoot a)
forall a. MerkleRoot a -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleRoot a -> ()
$crnf :: forall a. MerkleRoot a -> ()
NFData, Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
Proxy (MerkleRoot a) -> String
(Context -> MerkleRoot a -> IO (Maybe ThunkInfo))
-> (Context -> MerkleRoot a -> IO (Maybe ThunkInfo))
-> (Proxy (MerkleRoot a) -> String)
-> NoThunks (MerkleRoot a)
forall a. Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
forall a. Proxy (MerkleRoot a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (MerkleRoot a) -> String
$cshowTypeOf :: forall a. Proxy (MerkleRoot a) -> String
wNoThunks :: Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a. Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
noThunks :: Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
$cnoThunks :: forall a. Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
NoThunks)

instance Buildable (MerkleRoot a) where
  build :: MerkleRoot a -> Builder
build (MerkleRoot Hash Raw
h) = Builder
"MerkleRoot|" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Hash Raw -> Builder
forall p. Buildable p => p -> Builder
build Hash Raw
h

-- Used for debugging purposes only
instance ToJSON a => ToJSON (MerkleRoot a)

instance ToCBOR a => ToCBOR (MerkleRoot a) where
  toCBOR :: MerkleRoot a -> Encoding
toCBOR = Hash Raw -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Hash Raw -> Encoding)
-> (MerkleRoot a -> Hash Raw) -> MerkleRoot a -> Encoding
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MerkleRoot a -> Hash Raw
forall a. MerkleRoot a -> Hash Raw
getMerkleRoot
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (MerkleRoot a) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
size = (forall t. ToCBOR t => Proxy t -> Size) -> Proxy (Hash Raw) -> Size
forall a.
ToCBOR a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
size (Proxy (Hash Raw) -> Size)
-> (Proxy (MerkleRoot a) -> Proxy (Hash Raw))
-> Proxy (MerkleRoot a)
-> Size
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (MerkleRoot a -> Hash Raw)
-> Proxy (MerkleRoot a) -> Proxy (Hash Raw)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MerkleRoot a -> Hash Raw
forall a. MerkleRoot a -> Hash Raw
getMerkleRoot

instance FromCBOR a => FromCBOR (MerkleRoot a) where
  fromCBOR :: Decoder s (MerkleRoot a)
fromCBOR = Hash Raw -> MerkleRoot a
forall a. Hash Raw -> MerkleRoot a
MerkleRoot (Hash Raw -> MerkleRoot a)
-> Decoder s (Hash Raw) -> Decoder s (MerkleRoot a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Hash Raw)
forall a s. FromCBOR a => Decoder s a
fromCBOR

merkleRootToBuilder :: MerkleRoot a -> Builder
merkleRootToBuilder :: MerkleRoot a -> Builder
merkleRootToBuilder (MerkleRoot Hash Raw
h) = ByteString -> Builder
byteString (Hash Raw -> ByteString
forall algo a. AbstractHash algo a -> ByteString
hashToBytes Hash Raw
h)

mkRoot :: MerkleRoot a -> MerkleRoot a -> MerkleRoot a
mkRoot :: MerkleRoot a -> MerkleRoot a -> MerkleRoot a
mkRoot MerkleRoot a
a MerkleRoot a
b =
  Hash Raw -> MerkleRoot a
forall a. Hash Raw -> MerkleRoot a
MerkleRoot (Hash Raw -> MerkleRoot a)
-> (Builder -> Hash Raw) -> Builder -> MerkleRoot a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Hash Raw
hashRaw (ByteString -> Hash Raw)
-> (Builder -> ByteString) -> Builder -> Hash Raw
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> ByteString
toLazyByteString (Builder -> MerkleRoot a) -> Builder -> MerkleRoot a
forall a b. (a -> b) -> a -> b
$
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
      [Word8 -> Builder
word8 Word8
1, MerkleRoot a -> Builder
forall a. MerkleRoot a -> Builder
merkleRootToBuilder MerkleRoot a
a, MerkleRoot a -> Builder
forall a. MerkleRoot a -> Builder
merkleRootToBuilder MerkleRoot a
b]

emptyHash :: MerkleRoot a
emptyHash :: MerkleRoot a
emptyHash = Hash Raw -> MerkleRoot a
forall a. Hash Raw -> MerkleRoot a
MerkleRoot (ByteString -> Hash Raw
hashRaw ByteString
forall a. Monoid a => a
mempty)

--------------------------------------------------------------------------------
-- MerkleTree
--------------------------------------------------------------------------------

data MerkleTree a
  = MerkleEmpty
  | MerkleTree !Word32 !(MerkleNode a)
  deriving (MerkleTree a -> MerkleTree a -> Bool
(MerkleTree a -> MerkleTree a -> Bool)
-> (MerkleTree a -> MerkleTree a -> Bool) -> Eq (MerkleTree a)
forall a. Eq a => MerkleTree a -> MerkleTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleTree a -> MerkleTree a -> Bool
$c/= :: forall a. Eq a => MerkleTree a -> MerkleTree a -> Bool
== :: MerkleTree a -> MerkleTree a -> Bool
$c== :: forall a. Eq a => MerkleTree a -> MerkleTree a -> Bool
Eq, (forall x. MerkleTree a -> Rep (MerkleTree a) x)
-> (forall x. Rep (MerkleTree a) x -> MerkleTree a)
-> Generic (MerkleTree a)
forall x. Rep (MerkleTree a) x -> MerkleTree a
forall x. MerkleTree a -> Rep (MerkleTree a) x
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 anyclass (MerkleTree a -> ()
(MerkleTree a -> ()) -> NFData (MerkleTree a)
forall a. NFData a => MerkleTree a -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleTree a -> ()
$crnf :: forall a. NFData a => MerkleTree a -> ()
NFData)

instance Foldable MerkleTree where
  foldMap :: (a -> m) -> MerkleTree a -> m
foldMap a -> m
_ MerkleTree a
MerkleEmpty = m
forall a. Monoid a => a
mempty
  foldMap a -> m
f (MerkleTree Word32
_ MerkleNode a
n) = (a -> m) -> MerkleNode a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap a -> m
f MerkleNode a
n

  null :: MerkleTree a -> Bool
null MerkleTree a
MerkleEmpty = Bool
True
  null MerkleTree a
_ = Bool
False

  length :: MerkleTree a -> Int
length MerkleTree a
MerkleEmpty = Int
0
  length (MerkleTree Word32
s MerkleNode a
_) = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
s

instance Show a => Show (MerkleTree a) where
  show :: MerkleTree a -> String
show MerkleTree a
tree = String
"Merkle tree: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (MerkleTree a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList MerkleTree a
tree)

-- This instance is both faster and more space-efficient (as confirmed by a
-- benchmark). Hashing turns out to be faster than decoding extra data.
instance ToCBOR a => ToCBOR (MerkleTree a) where
  toCBOR :: MerkleTree a -> Encoding
toCBOR = [a] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ([a] -> Encoding)
-> (MerkleTree a -> [a]) -> MerkleTree a -> Encoding
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MerkleTree a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList

instance (FromCBOR a, ToCBOR a) => FromCBOR (MerkleTree a) where
  fromCBOR :: Decoder s (MerkleTree a)
fromCBOR = [a] -> MerkleTree a
forall a. ToCBOR a => [a] -> MerkleTree a
mkMerkleTree ([a] -> MerkleTree a) -> Decoder s [a] -> Decoder s (MerkleTree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [a]
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Smart constructor for 'MerkleTree'
mkMerkleTree :: ToCBOR a => [a] -> MerkleTree a
mkMerkleTree :: [a] -> MerkleTree a
mkMerkleTree = (Const a Any -> MerkleNode a) -> [Const a Any] -> MerkleTree a
forall (f :: * -> * -> *) a b.
(f a b -> MerkleNode a) -> [f a b] -> MerkleTree a
mkMerkleTree' (a -> MerkleNode a
forall a. ToCBOR a => a -> MerkleNode a
mkLeaf (a -> MerkleNode a)
-> (Const a Any -> a) -> Const a Any -> MerkleNode a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Const a Any -> a
forall a k (b :: k). Const a b -> a
getConst) ([Const a Any] -> MerkleTree a)
-> ([a] -> [Const a Any]) -> [a] -> MerkleTree a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> Const a Any) -> [a] -> [Const a Any]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Const a Any
forall k a (b :: k). a -> Const a b
Const

-- | Reconstruct a 'MerkleTree' from a decoded list of items
mkMerkleTreeDecoded :: [Annotated a ByteString] -> MerkleTree a
mkMerkleTreeDecoded :: [Annotated a ByteString] -> MerkleTree a
mkMerkleTreeDecoded = (Annotated a ByteString -> MerkleNode a)
-> [Annotated a ByteString] -> MerkleTree a
forall (f :: * -> * -> *) a b.
(f a b -> MerkleNode a) -> [f a b] -> MerkleTree a
mkMerkleTree' Annotated a ByteString -> MerkleNode a
forall a. Annotated a ByteString -> MerkleNode a
mkLeafDecoded

mkMerkleTree' ::
  forall f a b. (f a b -> MerkleNode a) -> [f a b] -> MerkleTree a
mkMerkleTree' :: (f a b -> MerkleNode a) -> [f a b] -> MerkleTree a
mkMerkleTree' f a b -> MerkleNode a
_ [] = MerkleTree a
forall a. MerkleTree a
MerkleEmpty
mkMerkleTree' f a b -> MerkleNode a
leafBuilder [f a b]
ls = Word32 -> MerkleNode a -> MerkleTree a
forall a. Word32 -> MerkleNode a -> MerkleTree a
MerkleTree (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lsLen) (Int -> [f a b] -> MerkleNode a
go Int
lsLen [f a b]
ls)
  where
    lsLen :: Int
lsLen = [f a b] -> Int
forall a. HasLength a => a -> Int
length [f a b]
ls
    go :: Int -> [f a b] -> MerkleNode a
    go :: Int -> [f a b] -> MerkleNode a
go Int
_ [f a b
x] = f a b -> MerkleNode a
leafBuilder f a b
x
    go Int
len [f a b]
xs = MerkleNode a -> MerkleNode a -> MerkleNode a
forall a. MerkleNode a -> MerkleNode a -> MerkleNode a
mkBranch (Int -> [f a b] -> MerkleNode a
go Int
i [f a b]
l) (Int -> [f a b] -> MerkleNode a
go (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) [f a b]
r)
      where
        i :: Int
i = Int -> Int
forall a. (Bits a, Num a) => a -> a
powerOfTwo Int
len
        ([f a b]
l, [f a b]
r) = Int -> [f a b] -> ([f a b], [f a b])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [f a b]
xs

-- | Return the largest power of two such that it's smaller than X.
--
-- >>> powerOfTwo 64
-- 32
-- >>> powerOfTwo 65
-- 64
powerOfTwo :: forall a. (Bits a, Num a) => a -> a
powerOfTwo :: a -> a
powerOfTwo a
n
  | a
n a -> a -> a
forall a. Bits a => a -> a -> a
.&. (a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
  | Bool
otherwise = a -> a
go a
n
  where
    {- “x .&. (x - 1)” clears the least significant bit:

           ↓
       01101000     x
       01100111     x - 1
       --------
       01100000     x .&. (x - 1)

       I could've used something like “until (\x -> x*2 > w) (*2) 1”,
       but bit tricks are fun. -}
    go :: a -> a
    go :: a -> a
go a
w = if a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then a
w else a -> a
go (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
1))

-- | Returns root of Merkle tree
mtRoot :: MerkleTree a -> MerkleRoot a
mtRoot :: MerkleTree a -> MerkleRoot a
mtRoot MerkleTree a
MerkleEmpty = MerkleRoot a
forall a. MerkleRoot a
emptyHash
mtRoot (MerkleTree Word32
_ MerkleNode a
n) = MerkleNode a -> MerkleRoot a
forall a. MerkleNode a -> MerkleRoot a
nodeRoot MerkleNode a
n

--------------------------------------------------------------------------------
-- MerkleNode
--------------------------------------------------------------------------------

data MerkleNode a
  = -- | MerkleBranch mRoot mLeft mRight
    MerkleBranch !(MerkleRoot a) !(MerkleNode a) !(MerkleNode a)
  | -- | MerkleLeaf mRoot mVal
    MerkleLeaf !(MerkleRoot a) a
  deriving (MerkleNode a -> MerkleNode a -> Bool
(MerkleNode a -> MerkleNode a -> Bool)
-> (MerkleNode a -> MerkleNode a -> Bool) -> Eq (MerkleNode a)
forall a. Eq a => MerkleNode a -> MerkleNode a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleNode a -> MerkleNode a -> Bool
$c/= :: forall a. Eq a => MerkleNode a -> MerkleNode a -> Bool
== :: MerkleNode a -> MerkleNode a -> Bool
$c== :: forall a. Eq a => MerkleNode a -> MerkleNode a -> Bool
Eq, Int -> MerkleNode a -> ShowS
[MerkleNode a] -> ShowS
MerkleNode a -> String
(Int -> MerkleNode a -> ShowS)
-> (MerkleNode a -> String)
-> ([MerkleNode a] -> ShowS)
-> Show (MerkleNode a)
forall a. Show a => Int -> MerkleNode a -> ShowS
forall a. Show a => [MerkleNode a] -> ShowS
forall a. Show a => MerkleNode a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MerkleNode a] -> ShowS
$cshowList :: forall a. Show a => [MerkleNode a] -> ShowS
show :: MerkleNode a -> String
$cshow :: forall a. Show a => MerkleNode a -> String
showsPrec :: Int -> MerkleNode a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> MerkleNode a -> ShowS
Show, (forall x. MerkleNode a -> Rep (MerkleNode a) x)
-> (forall x. Rep (MerkleNode a) x -> MerkleNode a)
-> Generic (MerkleNode a)
forall x. Rep (MerkleNode a) x -> MerkleNode a
forall x. MerkleNode a -> Rep (MerkleNode a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MerkleNode a) x -> MerkleNode a
forall a x. MerkleNode a -> Rep (MerkleNode a) x
$cto :: forall a x. Rep (MerkleNode a) x -> MerkleNode a
$cfrom :: forall a x. MerkleNode a -> Rep (MerkleNode a) x
Generic)
  deriving anyclass (MerkleNode a -> ()
(MerkleNode a -> ()) -> NFData (MerkleNode a)
forall a. NFData a => MerkleNode a -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleNode a -> ()
$crnf :: forall a. NFData a => MerkleNode a -> ()
NFData)

instance Foldable MerkleNode where
  foldMap :: (a -> m) -> MerkleNode a -> m
foldMap a -> m
f MerkleNode a
x = case MerkleNode a
x of
    MerkleLeaf MerkleRoot a
_ a
mVal -> a -> m
f a
mVal
    MerkleBranch MerkleRoot a
_ MerkleNode a
mLeft MerkleNode a
mRight ->
      (a -> m) -> MerkleNode a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap a -> m
f MerkleNode a
mLeft m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> MerkleNode a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap a -> m
f MerkleNode a
mRight

toLazyByteString :: Builder -> LBS.ByteString
toLazyByteString :: Builder -> ByteString
toLazyByteString =
  AllocationStrategy -> ByteString -> Builder -> ByteString
Builder.toLazyByteStringWith (Int -> Int -> AllocationStrategy
Builder.safeStrategy Int
1024 Int
4096) ByteString
forall a. Monoid a => a
mempty

nodeRoot :: MerkleNode a -> MerkleRoot a
nodeRoot :: MerkleNode a -> MerkleRoot a
nodeRoot (MerkleLeaf MerkleRoot a
root a
_) = MerkleRoot a
root
nodeRoot (MerkleBranch MerkleRoot a
root MerkleNode a
_ MerkleNode a
_) = MerkleRoot a
root

mkLeaf :: forall a. ToCBOR a => a -> MerkleNode a
mkLeaf :: a -> MerkleNode a
mkLeaf a
a = MerkleRoot a -> a -> MerkleNode a
forall a. MerkleRoot a -> a -> MerkleNode a
MerkleLeaf MerkleRoot a
mRoot a
a
  where
    mRoot :: MerkleRoot a
    mRoot :: MerkleRoot a
mRoot =
      Hash Raw -> MerkleRoot a
forall a. Hash Raw -> MerkleRoot a
MerkleRoot (Hash Raw -> MerkleRoot a) -> Hash Raw -> MerkleRoot a
forall a b. (a -> b) -> a -> b
$
        ByteString -> Hash Raw
hashRaw
          (Builder -> ByteString
toLazyByteString (Word8 -> Builder
word8 Word8
0 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall a. ToCBOR a => a -> Builder
serializeBuilder a
a))

mkLeafDecoded :: Annotated a ByteString -> MerkleNode a
mkLeafDecoded :: Annotated a ByteString -> MerkleNode a
mkLeafDecoded Annotated a ByteString
a = MerkleRoot a -> a -> MerkleNode a
forall a. MerkleRoot a -> a -> MerkleNode a
MerkleLeaf MerkleRoot a
forall a. MerkleRoot a
mRoot (Annotated a ByteString -> a
forall b a. Annotated b a -> b
unAnnotated Annotated a ByteString
a)
  where
    mRoot :: MerkleRoot a
    mRoot :: MerkleRoot a
mRoot = Hash Raw -> MerkleRoot a
forall a. Hash Raw -> MerkleRoot a
MerkleRoot (Hash Raw -> MerkleRoot a)
-> (Annotated a ByteString -> Hash Raw)
-> Annotated a ByteString
-> MerkleRoot a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Hash a -> Hash Raw
coerce (Hash a -> Hash Raw)
-> (Annotated a ByteString -> Hash a)
-> Annotated a ByteString
-> Hash Raw
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Annotated a ByteString -> Hash a
forall t. Decoded t => t -> Hash (BaseType t)
hashDecoded (Annotated a ByteString -> MerkleRoot a)
-> Annotated a ByteString -> MerkleRoot a
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
prependTag (ByteString -> ByteString)
-> Annotated a ByteString -> Annotated a ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotated a ByteString
a

    prependTag :: ByteString -> ByteString
prependTag = (ByteString -> ByteString
LBS.toStrict (Builder -> ByteString
toLazyByteString (Word8 -> Builder
word8 Word8
0)) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)

mkBranch :: MerkleNode a -> MerkleNode a -> MerkleNode a
mkBranch :: MerkleNode a -> MerkleNode a -> MerkleNode a
mkBranch MerkleNode a
nodeA MerkleNode a
nodeB = MerkleRoot a -> MerkleNode a -> MerkleNode a -> MerkleNode a
forall a.
MerkleRoot a -> MerkleNode a -> MerkleNode a -> MerkleNode a
MerkleBranch MerkleRoot a
root MerkleNode a
nodeA MerkleNode a
nodeB
  where
    root :: MerkleRoot a
root = MerkleRoot a -> MerkleRoot a -> MerkleRoot a
forall a. MerkleRoot a -> MerkleRoot a -> MerkleRoot a
mkRoot (MerkleNode a -> MerkleRoot a
forall a. MerkleNode a -> MerkleRoot a
nodeRoot MerkleNode a
nodeA) (MerkleNode a -> MerkleRoot a
forall a. MerkleNode a -> MerkleRoot a
nodeRoot MerkleNode a
nodeB)