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

module Cardano.Chain.Block.Proof (
  Proof (..),
  ProofValidationError (..),
  mkProof,
  recoverProof,
) where

import Cardano.Chain.Block.Body (
  ABody (..),
  Body,
  bodyDlgPayload,
  bodyTxPayload,
  bodyUpdatePayload,
 )
import qualified Cardano.Chain.Delegation.Payload as Delegation
import Cardano.Chain.Ssc (SscProof (..))
import Cardano.Chain.UTxO.TxProof (TxProof, mkTxProof, recoverTxProof)
import qualified Cardano.Chain.Update.Proof as Update
import Cardano.Crypto (Hash, hashDecoded, serializeCborHash)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  toByronCBOR,
 )
import Cardano.Prelude
import Data.Aeson (ToJSON)
import Formatting (bprint, build, shown)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))

-- | Proof of everything contained in the payload
data Proof = Proof
  { Proof -> TxProof
proofUTxO :: !TxProof
  , Proof -> SscProof
proofSsc :: !SscProof
  , Proof -> Hash Payload
proofDelegation :: !(Hash Delegation.Payload)
  , Proof -> Proof
proofUpdate :: !Update.Proof
  }
  deriving (Proof -> Proof -> Bool
(Proof -> Proof -> Bool) -> (Proof -> Proof -> Bool) -> Eq Proof
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Proof -> Proof -> Bool
== :: Proof -> Proof -> Bool
$c/= :: Proof -> Proof -> Bool
/= :: Proof -> Proof -> Bool
Eq, Int -> Proof -> ShowS
[Proof] -> ShowS
Proof -> String
(Int -> Proof -> ShowS)
-> (Proof -> String) -> ([Proof] -> ShowS) -> Show Proof
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Proof -> ShowS
showsPrec :: Int -> Proof -> ShowS
$cshow :: Proof -> String
show :: Proof -> String
$cshowList :: [Proof] -> ShowS
showList :: [Proof] -> ShowS
Show, (forall x. Proof -> Rep Proof x)
-> (forall x. Rep Proof x -> Proof) -> Generic Proof
forall x. Rep Proof x -> Proof
forall x. Proof -> Rep Proof x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Proof -> Rep Proof x
from :: forall x. Proof -> Rep Proof x
$cto :: forall x. Rep Proof x -> Proof
to :: forall x. Rep Proof x -> Proof
Generic, Proof -> ()
(Proof -> ()) -> NFData Proof
forall a. (a -> ()) -> NFData a
$crnf :: Proof -> ()
rnf :: Proof -> ()
NFData, Context -> Proof -> IO (Maybe ThunkInfo)
Proxy Proof -> String
(Context -> Proof -> IO (Maybe ThunkInfo))
-> (Context -> Proof -> IO (Maybe ThunkInfo))
-> (Proxy Proof -> String)
-> NoThunks Proof
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Proof -> IO (Maybe ThunkInfo)
noThunks :: Context -> Proof -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Proof -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Proof -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Proof -> String
showTypeOf :: Proxy Proof -> String
NoThunks)

instance B.Buildable Proof where
  build :: Proof -> Builder
build Proof
proof =
    Format
  Builder (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
-> TxProof -> SscProof -> Hash Payload -> Proof -> Builder
forall a. Format Builder a -> a
bprint
      (Format
  (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
  (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
"<Proof: " Format
  (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
  (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
-> Format
     Builder (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
-> Format
     Builder (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (SscProof -> Hash Payload -> Proof -> Builder)
  (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format
  (SscProof -> Hash Payload -> Proof -> Builder)
  (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
-> Format Builder (SscProof -> Hash Payload -> Proof -> Builder)
-> Format
     Builder (TxProof -> SscProof -> Hash Payload -> Proof -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (SscProof -> Hash Payload -> Proof -> Builder)
  (SscProof -> Hash Payload -> Proof -> Builder)
", " Format
  (SscProof -> Hash Payload -> Proof -> Builder)
  (SscProof -> Hash Payload -> Proof -> Builder)
-> Format Builder (SscProof -> Hash Payload -> Proof -> Builder)
-> Format Builder (SscProof -> Hash Payload -> Proof -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (Hash Payload -> Proof -> Builder)
  (SscProof -> Hash Payload -> Proof -> Builder)
forall a r. Show a => Format r (a -> r)
shown Format
  (Hash Payload -> Proof -> Builder)
  (SscProof -> Hash Payload -> Proof -> Builder)
-> Format Builder (Hash Payload -> Proof -> Builder)
-> Format Builder (SscProof -> Hash Payload -> Proof -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (Hash Payload -> Proof -> Builder)
  (Hash Payload -> Proof -> Builder)
", " Format
  (Hash Payload -> Proof -> Builder)
  (Hash Payload -> Proof -> Builder)
-> Format Builder (Hash Payload -> Proof -> Builder)
-> Format Builder (Hash Payload -> Proof -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Proof -> Builder) (Hash Payload -> Proof -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format (Proof -> Builder) (Hash Payload -> Proof -> Builder)
-> Format Builder (Proof -> Builder)
-> Format Builder (Hash Payload -> Proof -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Proof -> Builder) (Proof -> Builder)
", " Format (Proof -> Builder) (Proof -> Builder)
-> Format Builder (Proof -> Builder)
-> Format Builder (Proof -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Proof -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format Builder (Proof -> Builder)
-> Format Builder Builder -> Format Builder (Proof -> Builder)
forall b c a. Format b c -> Format a b -> Format a c
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
">")
      (Proof -> TxProof
proofUTxO Proof
proof)
      (Proof -> SscProof
proofSsc Proof
proof)
      (Proof -> Hash Payload
proofDelegation Proof
proof)
      (Proof -> Proof
proofUpdate Proof
proof)

instance ToCBOR Proof where
  toCBOR :: Proof -> Encoding
toCBOR = Proof -> Encoding
forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR Proof where
  fromCBOR :: forall s. Decoder s Proof
fromCBOR = Decoder s Proof
forall a s. DecCBOR a => Decoder s a
fromByronCBOR

-- Used for debugging purposes only
instance ToJSON Proof

instance EncCBOR Proof where
  encCBOR :: Proof -> Encoding
encCBOR Proof
bc =
    Word -> Encoding
encodeListLen Word
4
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> TxProof -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Proof -> TxProof
proofUTxO Proof
bc)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SscProof -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Proof -> SscProof
proofSsc Proof
bc)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Hash Payload -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Proof -> Hash Payload
proofDelegation Proof
bc)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Proof -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Proof -> Proof
proofUpdate Proof
bc)

  encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Proof -> Size
encodedSizeExpr forall t. EncCBOR t => Proxy t -> Size
size Proxy Proof
bc =
    Size
1
      Size -> Size -> Size
forall a. Num a => a -> a -> a
+ (forall t. EncCBOR t => Proxy t -> Size) -> Proxy TxProof -> 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 (Proof -> TxProof
proofUTxO (Proof -> TxProof) -> Proxy Proof -> Proxy TxProof
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Proof
bc)
      Size -> Size -> Size
forall a. Num a => a -> a -> a
+ (forall t. EncCBOR t => Proxy t -> Size) -> Proxy SscProof -> 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 (Proof -> SscProof
proofSsc (Proof -> SscProof) -> Proxy Proof -> Proxy SscProof
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Proof
bc)
      Size -> Size -> Size
forall a. Num a => a -> a -> a
+ (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (Hash Payload) -> 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 (Proof -> Hash Payload
proofDelegation (Proof -> Hash Payload) -> Proxy Proof -> Proxy (Hash Payload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Proof
bc)
      Size -> Size -> Size
forall a. Num a => a -> a -> a
+ (forall t. EncCBOR t => Proxy t -> Size) -> Proxy Proof -> 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 (Proof -> Proof
proofUpdate (Proof -> Proof) -> Proxy Proof -> Proxy Proof
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Proof
bc)

instance DecCBOR Proof where
  decCBOR :: forall s. Decoder s Proof
decCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Proof" Int
4
    TxProof -> SscProof -> Hash Payload -> Proof -> Proof
Proof (TxProof -> SscProof -> Hash Payload -> Proof -> Proof)
-> Decoder s TxProof
-> Decoder s (SscProof -> Hash Payload -> Proof -> Proof)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s TxProof
forall s. Decoder s TxProof
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (SscProof -> Hash Payload -> Proof -> Proof)
-> Decoder s SscProof -> Decoder s (Hash Payload -> Proof -> Proof)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s SscProof
forall s. Decoder s SscProof
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (Hash Payload -> Proof -> Proof)
-> Decoder s (Hash Payload) -> Decoder s (Proof -> Proof)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Hash Payload)
forall s. Decoder s (Hash Payload)
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (Proof -> Proof) -> Decoder s Proof -> Decoder s Proof
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s Proof
forall s. Decoder s Proof
forall a s. DecCBOR a => Decoder s a
decCBOR

mkProof :: Body -> Proof
mkProof :: Body -> Proof
mkProof Body
body =
  Proof
    { proofUTxO :: TxProof
proofUTxO = TxPayload -> TxProof
mkTxProof (TxPayload -> TxProof) -> TxPayload -> TxProof
forall a b. (a -> b) -> a -> b
$ Body -> TxPayload
forall a. ABody a -> ATxPayload a
bodyTxPayload Body
body
    , proofSsc :: SscProof
proofSsc = SscProof
SscProof
    , proofDelegation :: Hash Payload
proofDelegation = Payload -> Hash Payload
forall a. EncCBOR a => a -> Hash a
serializeCborHash (Payload -> Hash Payload) -> Payload -> Hash Payload
forall a b. (a -> b) -> a -> b
$ Body -> Payload
forall a. ABody a -> APayload a
bodyDlgPayload Body
body
    , proofUpdate :: Proof
proofUpdate = APayload () -> Proof
Update.mkProof (APayload () -> Proof) -> APayload () -> Proof
forall a b. (a -> b) -> a -> b
$ Body -> APayload ()
forall a. ABody a -> APayload a
bodyUpdatePayload Body
body
    }

-- TODO: Should we be using this somewhere?
recoverProof :: ABody ByteString -> Proof
recoverProof :: ABody ByteString -> Proof
recoverProof ABody ByteString
body =
  Proof
    { proofUTxO :: TxProof
proofUTxO = ATxPayload ByteString -> TxProof
recoverTxProof (ATxPayload ByteString -> TxProof)
-> ATxPayload ByteString -> TxProof
forall a b. (a -> b) -> a -> b
$ ABody ByteString -> ATxPayload ByteString
forall a. ABody a -> ATxPayload a
bodyTxPayload ABody ByteString
body
    , proofSsc :: SscProof
proofSsc = SscProof
SscProof
    , proofDelegation :: Hash Payload
proofDelegation = APayload ByteString -> Hash (BaseType (APayload ByteString))
forall t. Decoded t => t -> Hash (BaseType t)
hashDecoded (APayload ByteString -> Hash (BaseType (APayload ByteString)))
-> APayload ByteString -> Hash (BaseType (APayload ByteString))
forall a b. (a -> b) -> a -> b
$ ABody ByteString -> APayload ByteString
forall a. ABody a -> APayload a
bodyDlgPayload ABody ByteString
body
    , proofUpdate :: Proof
proofUpdate = APayload ByteString -> Proof
Update.recoverProof (APayload ByteString -> Proof) -> APayload ByteString -> Proof
forall a b. (a -> b) -> a -> b
$ ABody ByteString -> APayload ByteString
forall a. ABody a -> APayload a
bodyUpdatePayload ABody ByteString
body
    }

-- | Error which can result from attempting to validate an invalid payload
-- proof.
data ProofValidationError
  = -- | The delegation payload proof did not match
    DelegationProofValidationError
  | -- | The UTxO payload proof did not match
    UTxOProofValidationError
  | -- | The update payload proof did not match
    UpdateProofValidationError
  deriving (ProofValidationError -> ProofValidationError -> Bool
(ProofValidationError -> ProofValidationError -> Bool)
-> (ProofValidationError -> ProofValidationError -> Bool)
-> Eq ProofValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProofValidationError -> ProofValidationError -> Bool
== :: ProofValidationError -> ProofValidationError -> Bool
$c/= :: ProofValidationError -> ProofValidationError -> Bool
/= :: ProofValidationError -> ProofValidationError -> Bool
Eq, Int -> ProofValidationError -> ShowS
[ProofValidationError] -> ShowS
ProofValidationError -> String
(Int -> ProofValidationError -> ShowS)
-> (ProofValidationError -> String)
-> ([ProofValidationError] -> ShowS)
-> Show ProofValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProofValidationError -> ShowS
showsPrec :: Int -> ProofValidationError -> ShowS
$cshow :: ProofValidationError -> String
show :: ProofValidationError -> String
$cshowList :: [ProofValidationError] -> ShowS
showList :: [ProofValidationError] -> ShowS
Show)