{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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.Crypto (Hash, hashDecoded, hashRaw, hashToBytes)
import Cardano.Crypto.Raw (Raw)
import Cardano.Ledger.Binary (
  Annotated (..),
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  byronProtVer,
  fromByronCBOR,
  serializeBuilder,
  toByronCBOR,
 )
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 F
import Formatting.Buildable (Buildable (..))
import NoThunks.Class (NoThunks (..))
import qualified Prelude

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

-- | Data type for root of Merkle tree
newtype MerkleRoot a = MerkleRoot
  { forall a. MerkleRoot a -> Hash Raw
getMerkleRoot :: Hash Raw
  -- ^ returns root 'Hash' of Merkle Tree
  }
  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
$cshowsPrec :: forall a. Int -> MerkleRoot a -> ShowS
showsPrec :: Int -> MerkleRoot a -> ShowS
$cshow :: forall a. MerkleRoot a -> String
show :: MerkleRoot a -> String
$cshowList :: forall a. [MerkleRoot a] -> ShowS
showList :: [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
$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
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
$ccompare :: forall a. MerkleRoot a -> MerkleRoot a -> Ordering
compare :: MerkleRoot a -> MerkleRoot a -> Ordering
$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
>= :: MerkleRoot a -> MerkleRoot a -> Bool
$cmax :: forall a. MerkleRoot a -> MerkleRoot a -> MerkleRoot a
max :: MerkleRoot a -> MerkleRoot a -> MerkleRoot a
$cmin :: forall a. MerkleRoot a -> MerkleRoot a -> MerkleRoot a
min :: MerkleRoot a -> MerkleRoot a -> 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
$cfrom :: forall a x. MerkleRoot a -> Rep (MerkleRoot a) x
from :: forall x. MerkleRoot a -> Rep (MerkleRoot a) x
$cto :: forall a x. Rep (MerkleRoot a) x -> MerkleRoot a
to :: forall x. Rep (MerkleRoot a) x -> MerkleRoot a
Generic)
  deriving anyclass (MerkleRoot a -> ()
(MerkleRoot a -> ()) -> NFData (MerkleRoot a)
forall a. MerkleRoot a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. MerkleRoot a -> ()
rnf :: 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
$cnoThunks :: forall a. Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
noThunks :: Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a. Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MerkleRoot a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall a. Proxy (MerkleRoot a) -> String
showTypeOf :: Proxy (MerkleRoot a) -> String
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 EncCBOR a => ToCBOR (MerkleRoot a) where
  toCBOR :: MerkleRoot a -> Encoding
toCBOR = MerkleRoot a -> Encoding
forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance DecCBOR a => FromCBOR (MerkleRoot a) where
  fromCBOR :: forall s. Decoder s (MerkleRoot a)
fromCBOR = Decoder s (MerkleRoot a)
forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR a => EncCBOR (MerkleRoot a) where
  encCBOR :: MerkleRoot a -> Encoding
encCBOR = Hash Raw -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Hash Raw -> Encoding)
-> (MerkleRoot a -> Hash Raw) -> MerkleRoot a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
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. EncCBOR t => Proxy t -> Size)
-> Proxy (MerkleRoot a) -> Size
encodedSizeExpr forall t. EncCBOR t => Proxy t -> Size
size = (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (Hash Raw) -> Size
forall a.
EncCBOR a =>
(forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr Proxy t -> Size
forall t. EncCBOR t => Proxy t -> Size
size (Proxy (Hash Raw) -> Size)
-> (Proxy (MerkleRoot a) -> Proxy (Hash Raw))
-> Proxy (MerkleRoot a)
-> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 a b. (a -> b) -> Proxy a -> Proxy b
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 DecCBOR a => DecCBOR (MerkleRoot a) where
  decCBOR :: forall s. Decoder s (MerkleRoot a)
decCBOR = 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 s. Decoder s (Hash Raw)
forall a s. DecCBOR a => Decoder s a
decCBOR

merkleRootToBuilder :: MerkleRoot a -> Builder
merkleRootToBuilder :: forall a. 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 :: forall a. 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 :: forall a. 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
$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
/= :: 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
$cfrom :: forall a x. MerkleTree a -> Rep (MerkleTree a) x
from :: forall x. MerkleTree a -> Rep (MerkleTree a) x
$cto :: forall a x. Rep (MerkleTree a) x -> MerkleTree a
to :: forall x. Rep (MerkleTree a) x -> MerkleTree a
Generic)
  deriving anyclass (MerkleTree a -> ()
(MerkleTree a -> ()) -> NFData (MerkleTree a)
forall a. NFData a => MerkleTree a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => MerkleTree a -> ()
rnf :: MerkleTree a -> ()
NFData)

instance Foldable MerkleTree where
  foldMap :: forall m a. Monoid m => (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 m a. Monoid m => (a -> m) -> MerkleNode a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap a -> m
f MerkleNode a
n

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

  length :: forall a. 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 a. MerkleTree a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList MerkleTree a
tree)

instance EncCBOR a => ToCBOR (MerkleTree a) where
  toCBOR :: MerkleTree a -> Encoding
toCBOR = MerkleTree a -> Encoding
forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance (DecCBOR a, EncCBOR a) => FromCBOR (MerkleTree a) where
  fromCBOR :: forall s. Decoder s (MerkleTree a)
fromCBOR = Decoder s (MerkleTree a)
forall a s. DecCBOR a => Decoder s a
fromByronCBOR

-- 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 EncCBOR a => EncCBOR (MerkleTree a) where
  encCBOR :: MerkleTree a -> Encoding
encCBOR = [a] -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ([a] -> Encoding)
-> (MerkleTree a -> [a]) -> MerkleTree a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 a. MerkleTree a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList

instance (DecCBOR a, EncCBOR a) => DecCBOR (MerkleTree a) where
  decCBOR :: forall s. Decoder s (MerkleTree a)
decCBOR = [a] -> MerkleTree a
forall a. EncCBOR 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 s. Decoder s [a]
forall a s. DecCBOR a => Decoder s a
decCBOR

-- | Smart constructor for 'MerkleTree'
mkMerkleTree :: EncCBOR a => [a] -> MerkleTree a
mkMerkleTree :: forall a. EncCBOR a => [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. EncCBOR a => a -> MerkleNode a
mkLeaf (a -> MerkleNode a)
-> (Const a Any -> a) -> Const a Any -> MerkleNode a
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 {k} a (b :: k). Const a b -> a
getConst) ([Const a Any] -> MerkleTree a)
-> ([a] -> [Const a Any]) -> [a] -> MerkleTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 a b. (a -> b) -> [a] -> [b]
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 :: forall a. [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' :: forall (f :: * -> * -> *) a b.
(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 :: forall a. (Bits a, Num a) => 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 :: forall a. 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
$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
/= :: 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
$cshowsPrec :: forall a. Show a => Int -> MerkleNode a -> ShowS
showsPrec :: Int -> MerkleNode a -> ShowS
$cshow :: forall a. Show a => MerkleNode a -> String
show :: MerkleNode a -> String
$cshowList :: forall a. Show a => [MerkleNode a] -> ShowS
showList :: [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
$cfrom :: forall a x. MerkleNode a -> Rep (MerkleNode a) x
from :: forall x. MerkleNode a -> Rep (MerkleNode a) x
$cto :: forall a x. Rep (MerkleNode a) x -> MerkleNode a
to :: forall x. Rep (MerkleNode a) x -> MerkleNode a
Generic)
  deriving anyclass (MerkleNode a -> ()
(MerkleNode a -> ()) -> NFData (MerkleNode a)
forall a. NFData a => MerkleNode a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => MerkleNode a -> ()
rnf :: MerkleNode a -> ()
NFData)

instance Foldable MerkleNode where
  foldMap :: forall m a. Monoid m => (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 m a. Monoid m => (a -> m) -> MerkleNode a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap a -> m
f MerkleNode a
mLeft m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> MerkleNode a -> m
forall m a. Monoid m => (a -> m) -> MerkleNode a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.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 :: forall a. 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. EncCBOR a => a -> MerkleNode a
mkLeaf :: forall a. EncCBOR a => 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
<> Version -> a -> Builder
forall a. EncCBOR a => Version -> a -> Builder
serializeBuilder Version
byronProtVer a
a))

mkLeafDecoded :: Annotated a ByteString -> MerkleNode a
mkLeafDecoded :: forall a. 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 :: forall a. 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 b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Hash (BaseType (Annotated a ByteString)) -> Hash Raw
forall a b. Coercible a b => a -> b
coerce (Hash (BaseType (Annotated a ByteString)) -> Hash Raw)
-> (Annotated a ByteString
    -> Hash (BaseType (Annotated a ByteString)))
-> Annotated a ByteString
-> Hash Raw
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (BaseType (Annotated a ByteString))
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 :: forall a. 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)