{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}

module Cardano.Chain.UTxO.TxProof
  ( TxProof (..),
    mkTxProof,
    recoverTxProof,
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen, enforceSize)
import Cardano.Chain.Common.Merkle
  ( MerkleRoot,
    mkMerkleTree,
    mkMerkleTreeDecoded,
    mtRoot,
  )
import Cardano.Chain.UTxO.Tx (Tx)
import Cardano.Chain.UTxO.TxPayload
  ( ATxPayload,
    TxPayload,
    recoverHashedBytes,
    txpAnnotatedTxs,
    txpTxs,
    txpWitnesses,
  )
import Cardano.Chain.UTxO.TxWitness (TxWitness)
import Cardano.Crypto (Hash, hashDecoded, serializeCborHash)
import Cardano.Prelude
import Data.Aeson (ToJSON)
import Formatting (bprint, build)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))

data TxProof = TxProof
  { TxProof -> Word32
txpNumber :: !Word32,
    TxProof -> MerkleRoot Tx
txpRoot :: !(MerkleRoot Tx),
    TxProof -> Hash [TxWitness]
txpWitnessesHash :: !(Hash [TxWitness])
  }
  deriving (Int -> TxProof -> ShowS
[TxProof] -> ShowS
TxProof -> String
(Int -> TxProof -> ShowS)
-> (TxProof -> String) -> ([TxProof] -> ShowS) -> Show TxProof
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxProof] -> ShowS
$cshowList :: [TxProof] -> ShowS
show :: TxProof -> String
$cshow :: TxProof -> String
showsPrec :: Int -> TxProof -> ShowS
$cshowsPrec :: Int -> TxProof -> ShowS
Show, TxProof -> TxProof -> Bool
(TxProof -> TxProof -> Bool)
-> (TxProof -> TxProof -> Bool) -> Eq TxProof
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxProof -> TxProof -> Bool
$c/= :: TxProof -> TxProof -> Bool
== :: TxProof -> TxProof -> Bool
$c== :: TxProof -> TxProof -> Bool
Eq, (forall x. TxProof -> Rep TxProof x)
-> (forall x. Rep TxProof x -> TxProof) -> Generic TxProof
forall x. Rep TxProof x -> TxProof
forall x. TxProof -> Rep TxProof x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TxProof x -> TxProof
$cfrom :: forall x. TxProof -> Rep TxProof x
Generic, Context -> TxProof -> IO (Maybe ThunkInfo)
Proxy TxProof -> String
(Context -> TxProof -> IO (Maybe ThunkInfo))
-> (Context -> TxProof -> IO (Maybe ThunkInfo))
-> (Proxy TxProof -> String)
-> NoThunks TxProof
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy TxProof -> String
$cshowTypeOf :: Proxy TxProof -> String
wNoThunks :: Context -> TxProof -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TxProof -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxProof -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> TxProof -> IO (Maybe ThunkInfo)
NoThunks)
  deriving anyclass (TxProof -> ()
(TxProof -> ()) -> NFData TxProof
forall a. (a -> ()) -> NFData a
rnf :: TxProof -> ()
$crnf :: TxProof -> ()
NFData)

-- Used for debugging purposes only
instance ToJSON TxProof

instance B.Buildable TxProof where
  build :: TxProof -> Builder
build TxProof
proof =
    Format
  Builder (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
-> Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder
forall a. Format Builder a -> a
bprint
      (Format
  (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
  (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
"<TxProof: " Format
  (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
  (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
-> Format
     Builder (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
-> Format
     Builder (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
  (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format
  (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
  (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
-> Format Builder (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
-> Format
     Builder (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
  (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
", " Format
  (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
  (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
-> Format Builder (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
-> Format Builder (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (Hash [TxWitness] -> Builder)
  (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format
  (Hash [TxWitness] -> Builder)
  (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
-> Format Builder (Hash [TxWitness] -> Builder)
-> Format Builder (MerkleRoot Tx -> Hash [TxWitness] -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Hash [TxWitness] -> Builder) (Hash [TxWitness] -> Builder)
", " Format (Hash [TxWitness] -> Builder) (Hash [TxWitness] -> Builder)
-> Format Builder (Hash [TxWitness] -> Builder)
-> Format Builder (Hash [TxWitness] -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Hash [TxWitness] -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format Builder (Hash [TxWitness] -> Builder)
-> Format Builder Builder
-> Format Builder (Hash [TxWitness] -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
">")
      (TxProof -> Word32
txpNumber TxProof
proof)
      (TxProof -> MerkleRoot Tx
txpRoot TxProof
proof)
      (TxProof -> Hash [TxWitness]
txpWitnessesHash TxProof
proof)

instance ToCBOR TxProof where
  toCBOR :: TxProof -> Encoding
toCBOR TxProof
proof =
    Word -> Encoding
encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (TxProof -> Word32
txpNumber TxProof
proof)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> MerkleRoot Tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (TxProof -> MerkleRoot Tx
txpRoot TxProof
proof)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Hash [TxWitness] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (TxProof -> Hash [TxWitness]
txpWitnessesHash TxProof
proof)
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size) -> Proxy TxProof -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
size Proxy TxProof
proof =
    Size
1
      Size -> Size -> Size
forall a. Num a => a -> a -> a
+ (forall t. ToCBOR t => Proxy t -> Size) -> Proxy Word32 -> Size
forall a.
ToCBOR a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
size (TxProof -> Word32
txpNumber (TxProof -> Word32) -> Proxy TxProof -> Proxy Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy TxProof
proof)
      Size -> Size -> Size
forall a. Num a => a -> a -> a
+ (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (MerkleRoot Tx) -> Size
forall a.
ToCBOR a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
size (TxProof -> MerkleRoot Tx
txpRoot (TxProof -> MerkleRoot Tx)
-> Proxy TxProof -> Proxy (MerkleRoot Tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy TxProof
proof)
      Size -> Size -> Size
forall a. Num a => a -> a -> a
+ (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (Hash [TxWitness]) -> Size
forall a.
ToCBOR a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
size (TxProof -> Hash [TxWitness]
txpWitnessesHash (TxProof -> Hash [TxWitness])
-> Proxy TxProof -> Proxy (Hash [TxWitness])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy TxProof
proof)

instance FromCBOR TxProof where
  fromCBOR :: Decoder s TxProof
fromCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"TxProof" Int
3
    Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> TxProof
TxProof (Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> TxProof)
-> Decoder s Word32
-> Decoder s (MerkleRoot Tx -> Hash [TxWitness] -> TxProof)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word32
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (MerkleRoot Tx -> Hash [TxWitness] -> TxProof)
-> Decoder s (MerkleRoot Tx)
-> Decoder s (Hash [TxWitness] -> TxProof)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (MerkleRoot Tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (Hash [TxWitness] -> TxProof)
-> Decoder s (Hash [TxWitness]) -> Decoder s TxProof
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Hash [TxWitness])
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Construct 'TxProof' which proves given 'TxPayload'
--
--   This will construct a Merkle tree, which can be very expensive. Use with
--   care.
mkTxProof :: TxPayload -> TxProof
mkTxProof :: TxPayload -> TxProof
mkTxProof TxPayload
payload =
  TxProof :: Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> TxProof
TxProof
    { txpNumber :: Word32
txpNumber = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Tx] -> Int
forall a. HasLength a => a -> Int
length ([Tx] -> Int) -> [Tx] -> Int
forall a b. (a -> b) -> a -> b
$ TxPayload -> [Tx]
forall a. ATxPayload a -> [Tx]
txpTxs TxPayload
payload),
      txpRoot :: MerkleRoot Tx
txpRoot = MerkleTree Tx -> MerkleRoot Tx
forall a. MerkleTree a -> MerkleRoot a
mtRoot ([Tx] -> MerkleTree Tx
forall a. ToCBOR a => [a] -> MerkleTree a
mkMerkleTree ([Tx] -> MerkleTree Tx) -> [Tx] -> MerkleTree Tx
forall a b. (a -> b) -> a -> b
$ TxPayload -> [Tx]
forall a. ATxPayload a -> [Tx]
txpTxs TxPayload
payload),
      txpWitnessesHash :: Hash [TxWitness]
txpWitnessesHash = [TxWitness] -> Hash [TxWitness]
forall a. ToCBOR a => a -> Hash a
serializeCborHash ([TxWitness] -> Hash [TxWitness])
-> [TxWitness] -> Hash [TxWitness]
forall a b. (a -> b) -> a -> b
$ TxPayload -> [TxWitness]
txpWitnesses TxPayload
payload
    }

recoverTxProof :: ATxPayload ByteString -> TxProof
recoverTxProof :: ATxPayload ByteString -> TxProof
recoverTxProof ATxPayload ByteString
payload =
  TxProof :: Word32 -> MerkleRoot Tx -> Hash [TxWitness] -> TxProof
TxProof
    { txpNumber :: Word32
txpNumber = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Tx] -> Int
forall a. HasLength a => a -> Int
length ([Tx] -> Int) -> [Tx] -> Int
forall a b. (a -> b) -> a -> b
$ ATxPayload ByteString -> [Tx]
forall a. ATxPayload a -> [Tx]
txpTxs ATxPayload ByteString
payload),
      txpRoot :: MerkleRoot Tx
txpRoot = MerkleTree Tx -> MerkleRoot Tx
forall a. MerkleTree a -> MerkleRoot a
mtRoot ([Annotated Tx ByteString] -> MerkleTree Tx
forall a. [Annotated a ByteString] -> MerkleTree a
mkMerkleTreeDecoded ([Annotated Tx ByteString] -> MerkleTree Tx)
-> [Annotated Tx ByteString] -> MerkleTree Tx
forall a b. (a -> b) -> a -> b
$ ATxPayload ByteString -> [Annotated Tx ByteString]
forall a. ATxPayload a -> [Annotated Tx a]
txpAnnotatedTxs ATxPayload ByteString
payload),
      txpWitnessesHash :: Hash [TxWitness]
txpWitnessesHash = Annotated [TxWitness] ByteString
-> Hash (BaseType (Annotated [TxWitness] ByteString))
forall t. Decoded t => t -> Hash (BaseType t)
hashDecoded (Annotated [TxWitness] ByteString
 -> Hash (BaseType (Annotated [TxWitness] ByteString)))
-> Annotated [TxWitness] ByteString
-> Hash (BaseType (Annotated [TxWitness] ByteString))
forall a b. (a -> b) -> a -> b
$ ATxPayload ByteString -> Annotated [TxWitness] ByteString
recoverHashedBytes ATxPayload ByteString
payload
    }