{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | JSON rendering helpers for Shelley-era ledger types used by the tracing
-- instances in "Ouroboros.Consensus.Tracing.Era.Shelley".
--
-- These were originally in @cardano-node@'s @Cardano.Node.Tracing.Render@ and
-- went through @cardano-api@. They are reimplemented here directly against
-- @cardano-ledger@ (so Consensus need not depend on @cardano-api@, which sits
-- downstream), reproducing @cardano-api@'s output: bech32 stake/reward
-- addresses (CIP-19), hex script hashes, and era-generic plutus purposes.
module Ouroboros.Consensus.Tracing.Era.Shelley.Render
  ( renderScriptHash
  , renderScriptIntegrityHash
  , renderScriptPurpose
  , renderScriptIndex
  , renderMissingRedeemers
  , renderIncompleteWithdrawals
  , renderRewardAccount
  , renderTxIn
  ) where

import qualified Cardano.Crypto.Hash.Class as Crypto
import Cardano.Ledger.Address (AccountAddress (..), serialiseAccountAddress)
import Cardano.Ledger.Alonzo.Scripts (AsItem (..), AsIx (..))
import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
import Cardano.Ledger.Api.Scripts
  ( AnyEraScript
  , PlutusPurpose
  , pattern AnyEraCertifyingPurpose
  , pattern AnyEraGuardingPurpose
  , pattern AnyEraMintingPurpose
  , pattern AnyEraProposingPurpose
  , pattern AnyEraSpendingPurpose
  , pattern AnyEraVotingPurpose
  , pattern AnyEraWithdrawingPurpose
  )
import Cardano.Ledger.BaseTypes
  ( Mismatch (..)
  , Network (..)
  , TxIx (..)
  )
import Cardano.Ledger.Conway.Governance (ProposalProcedure)
import qualified Cardano.Ledger.Core as Ledger
import Cardano.Ledger.Hashes (ScriptHash (..))
import qualified Cardano.Ledger.Hashes as Hashes
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import qualified Codec.Binary.Bech32 as Bech32
import Data.Aeson (ToJSON, Value, toJSON, (.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson
import qualified Data.ByteString.Base16 as B16
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map.NonEmpty (NonEmptyMap)
import qualified Data.Map.NonEmpty as NonEmptyMap
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text.Encoding
import Data.Typeable (Typeable)
import Data.Word (Word32)

-- | Hex-encode a script hash, matching @cardano-api@'s
-- @serialiseToRawBytesHexText . fromShelleyScriptHash@.
renderScriptHash :: ScriptHash -> Text
renderScriptHash :: ScriptHash -> Text
renderScriptHash (ScriptHash Hash ADDRHASH EraIndependentScript
h) = Hash ADDRHASH EraIndependentScript -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex Hash ADDRHASH EraIndependentScript
h

renderScriptIntegrityHash :: Maybe Alonzo.ScriptIntegrityHash -> Value
renderScriptIntegrityHash :: Maybe ScriptIntegrityHash -> Value
renderScriptIntegrityHash (Just ScriptIntegrityHash
witPPDataHash) =
  Text -> Value
Aeson.String (Text -> Value)
-> (Hash HASH EraIndependentScriptIntegrity -> Text)
-> Hash HASH EraIndependentScriptIntegrity
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash HASH EraIndependentScriptIntegrity -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash HASH EraIndependentScriptIntegrity -> Value)
-> Hash HASH EraIndependentScriptIntegrity -> Value
forall a b. (a -> b) -> a -> b
$ ScriptIntegrityHash -> Hash HASH EraIndependentScriptIntegrity
forall i. SafeHash i -> Hash HASH i
Hashes.extractHash ScriptIntegrityHash
witPPDataHash
renderScriptIntegrityHash Maybe ScriptIntegrityHash
Nothing = Value
Aeson.Null

-- | Bech32-encode a reward/stake account address (CIP-19), matching
-- @cardano-api@'s @serialiseAddress . fromShelleyStakeAddr@: human-readable
-- part @stake@ on mainnet, @stake_test@ on testnets.
renderRewardAccount :: AccountAddress -> Text
renderRewardAccount :: AccountAddress -> Text
renderRewardAccount AccountAddress
acct =
  case HumanReadablePart -> DataPart -> Either EncodingError Text
Bech32.encode HumanReadablePart
hrp (ByteString -> DataPart
Bech32.dataPartFromBytes ByteString
bytes) of
    Right Text
t -> Text
t
    -- 'encode' only fails if the payload exceeds bech32 length limits, which
    -- a 29-byte stake address never does; fall back to hex just in case.
    Left EncodingError
_ -> ByteString -> Text
Text.Encoding.decodeLatin1 (ByteString -> ByteString
B16.encode ByteString
bytes)
 where
  bytes :: ByteString
bytes = AccountAddress -> ByteString
serialiseAccountAddress AccountAddress
acct
  hrp :: HumanReadablePart
hrp = case AccountAddress -> Network
aaNetworkId AccountAddress
acct of
    Network
Mainnet -> HumanReadablePart
hrpStake
    Network
Testnet -> HumanReadablePart
hrpStakeTest

hrpStake, hrpStakeTest :: Bech32.HumanReadablePart
hrpStake :: HumanReadablePart
hrpStake = Text -> HumanReadablePart
unsafeHrp Text
"stake"
hrpStakeTest :: HumanReadablePart
hrpStakeTest = Text -> HumanReadablePart
unsafeHrp Text
"stake_test"

-- | These literals are valid human-readable parts, so this never fails.
unsafeHrp :: Text -> Bech32.HumanReadablePart
unsafeHrp :: Text -> HumanReadablePart
unsafeHrp Text
t = case Text -> Either HumanReadablePartError HumanReadablePart
Bech32.humanReadablePartFromText Text
t of
  Right HumanReadablePart
hrp -> HumanReadablePart
hrp
  Left HumanReadablePartError
err -> [Char] -> HumanReadablePart
forall a. HasCallStack => [Char] -> a
error ([Char]
"renderRewardAccount: invalid HRP " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
t [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> HumanReadablePartError -> [Char]
forall a. Show a => a -> [Char]
show HumanReadablePartError
err)

-- | Render a transaction input as @\<txid hex\>#\<index\>@.
--
-- Deliberately not @cardano-ledger@'s @ToJSON TxIn@: that one shows the index
-- newtype, giving @...#TxIx {unTxIx = 0}@. @cardano-api@ rendered the bare
-- number, and that is what the log has always carried.
renderTxIn :: TxIn -> Text
renderTxIn :: TxIn -> Text
renderTxIn (TxIn (TxId SafeHash EraIndependentTxBody
h) (TxIx Word16
ix)) =
  Hash HASH EraIndependentTxBody -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody
forall i. SafeHash i -> Hash HASH i
Hashes.extractHash SafeHash EraIndependentTxBody
h) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (Word16 -> [Char]
forall a. Show a => a -> [Char]
show Word16
ix)

-- | Render a plutus script purpose (as an item), era-generically via
-- @cardano-ledger-api@'s @AnyEraScript@ projections. Replaces @cardano-api@'s
-- per-era @renderAlonzoPlutusPurpose@/@renderConwayPlutusPurpose@.
--
-- The projections are pattern synonyms, but @cardano-ledger-api@ ships a
-- @COMPLETE@ pragma covering all seven of them, so GHC does check exhaustiveness
-- here. Matching all seven rather than falling through to a catch-all means the
-- next ledger era shows up as a warning at compile time instead of as an
-- unrenderable purpose in an operator's logs.
renderScriptPurpose ::
  ( AnyEraScript era
  , ToJSON (Ledger.TxCert era)
  , ToJSON (ProposalProcedure era)
  ) =>
  PlutusPurpose AsItem era ->
  Value
-- Note the asymmetry in whether the 'AsItem' wrapper is unwrapped: spending,
-- rewarding and guarding render their item directly, the other four go through
-- @ToJSON (AsItem ix it)@ and so come out wrapped in an @{"item": ...}@ object.
-- That is what @cardano-api@'s renderer did for the six purposes it knew about,
-- so it is what consumers parse; changing it is a deliberate format change, not
-- a cleanup to make here. Guarding is new in Dijkstra and has no @cardano-api@
-- rendering to preserve, so it renders directly, like the other two purposes
-- for which we have a dedicated renderer.
renderScriptPurpose :: forall era.
(AnyEraScript era, ToJSON (TxCert era),
 ToJSON (ProposalProcedure era)) =>
PlutusPurpose AsItem era -> Value
renderScriptPurpose = \case
  AnyEraSpendingPurpose (AsItem TxIn
txin) ->
    [(Key, Value)] -> Value
Aeson.object [Key
"spending" Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String (TxIn -> Text
renderTxIn TxIn
txin)]
  AnyEraMintingPurpose AsItem Word32 PolicyID
pid ->
    [(Key, Value)] -> Value
Aeson.object [Key
"minting" Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AsItem Word32 PolicyID -> Value
forall a. ToJSON a => a -> Value
toJSON AsItem Word32 PolicyID
pid]
  AnyEraWithdrawingPurpose (AsItem AccountAddress
rwdAcct) ->
    [(Key, Value)] -> Value
Aeson.object [Key
"rewarding" Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String (AccountAddress -> Text
renderRewardAccount AccountAddress
rwdAcct)]
  AnyEraCertifyingPurpose AsItem Word32 (TxCert era)
cert ->
    [(Key, Value)] -> Value
Aeson.object [Key
"certifying" Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AsItem Word32 (TxCert era) -> Value
forall a. ToJSON a => a -> Value
toJSON AsItem Word32 (TxCert era)
cert]
  AnyEraVotingPurpose AsItem Word32 Voter
voter ->
    [(Key, Value)] -> Value
Aeson.object [Key
"voting" Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AsItem Word32 Voter -> Value
forall a. ToJSON a => a -> Value
toJSON AsItem Word32 Voter
voter]
  AnyEraProposingPurpose AsItem Word32 (ProposalProcedure era)
proposal ->
    [(Key, Value)] -> Value
Aeson.object [Key
"proposing" Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AsItem Word32 (ProposalProcedure era) -> Value
forall a. ToJSON a => a -> Value
toJSON AsItem Word32 (ProposalProcedure era)
proposal]
  AnyEraGuardingPurpose (AsItem ScriptHash
sHash) ->
    [(Key, Value)] -> Value
Aeson.object [Key
"guarding" Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String (ScriptHash -> Text
renderScriptHash ScriptHash
sHash)]

-- | Render a plutus script purpose given by its index (redeemer pointer),
-- era-generically.
--
-- Reproduces what @cardano-api@'s @toScriptIndex@ followed by
-- @ToJSON ScriptWitnessIndex@ emitted: a @kind@ naming the witness index
-- constructor and the index itself under @value@. The constructor names are
-- @cardano-api@'s and do not all match the purpose names used by
-- 'renderScriptPurpose' above. @ScriptWitnessIndexGuarding@ is the exception:
-- @cardano-api@ has no constructor for the Dijkstra-era guarding purpose, so
-- that name is ours, following the same scheme.
renderScriptIndex :: AnyEraScript era => PlutusPurpose AsIx era -> Value
renderScriptIndex :: forall era. AnyEraScript era => PlutusPurpose AsIx era -> Value
renderScriptIndex = \case
  AnyEraSpendingPurpose (AsIx Word32
ix) -> Text -> Word32 -> Value
witnessIndex Text
"ScriptWitnessIndexTxIn" Word32
ix
  AnyEraMintingPurpose (AsIx Word32
ix) -> Text -> Word32 -> Value
witnessIndex Text
"ScriptWitnessIndexMint" Word32
ix
  AnyEraWithdrawingPurpose (AsIx Word32
ix) -> Text -> Word32 -> Value
witnessIndex Text
"ScriptWitnessIndexWithdrawal" Word32
ix
  AnyEraCertifyingPurpose (AsIx Word32
ix) -> Text -> Word32 -> Value
witnessIndex Text
"ScriptWitnessIndexCertificate" Word32
ix
  AnyEraVotingPurpose (AsIx Word32
ix) -> Text -> Word32 -> Value
witnessIndex Text
"ScriptWitnessIndexVoting" Word32
ix
  AnyEraProposingPurpose (AsIx Word32
ix) -> Text -> Word32 -> Value
witnessIndex Text
"ScriptWitnessIndexProposing" Word32
ix
  AnyEraGuardingPurpose (AsIx Word32
ix) -> Text -> Word32 -> Value
witnessIndex Text
"ScriptWitnessIndexGuarding" Word32
ix
 where
  witnessIndex :: Text -> Word32 -> Value
  witnessIndex :: Text -> Word32 -> Value
witnessIndex Text
kind Word32
ix = [(Key, Value)] -> Value
Aeson.object [Key
"kind" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
kind, Key
"value" Key -> Word32 -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word32
ix]

renderMissingRedeemers ::
  ( AnyEraScript era
  , Ledger.EraPParams era
  , ToJSON (Ledger.TxCert era)
  ) =>
  NonEmpty (PlutusPurpose AsItem era, ScriptHash) ->
  Value
renderMissingRedeemers :: forall era.
(AnyEraScript era, EraPParams era, ToJSON (TxCert era)) =>
NonEmpty (PlutusPurpose AsItem era, ScriptHash) -> Value
renderMissingRedeemers NonEmpty (PlutusPurpose AsItem era, ScriptHash)
scripts =
  [(Key, Value)] -> Value
Aeson.object ([(Key, Value)] -> Value) -> [(Key, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ NonEmpty (Key, Value) -> [(Key, Value)]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty (Key, Value) -> [(Key, Value)])
-> NonEmpty (Key, Value) -> [(Key, Value)]
forall a b. (a -> b) -> a -> b
$ ((PlutusPurpose AsItem era, ScriptHash) -> (Key, Value))
-> NonEmpty (PlutusPurpose AsItem era, ScriptHash)
-> NonEmpty (Key, Value)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (PlutusPurpose AsItem era, ScriptHash) -> (Key, Value)
forall {era} {e} {kv}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 KeyValue e kv, AnyEraScript era, EraPParams era,
 ToJSON (TxCert era)) =>
(PlutusPurpose AsItem era, ScriptHash) -> kv
renderTuple NonEmpty (PlutusPurpose AsItem era, ScriptHash)
scripts
 where
  renderTuple :: (PlutusPurpose AsItem era, ScriptHash) -> kv
renderTuple (PlutusPurpose AsItem era
scriptPurpose, ScriptHash
sHash) =
    Text -> Key
Aeson.fromText (ScriptHash -> Text
renderScriptHash ScriptHash
sHash) Key -> Value -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PlutusPurpose AsItem era -> Value
forall era.
(AnyEraScript era, ToJSON (TxCert era),
 ToJSON (ProposalProcedure era)) =>
PlutusPurpose AsItem era -> Value
renderScriptPurpose PlutusPurpose AsItem era
scriptPurpose

renderIncompleteWithdrawals ::
  (Typeable rel, Show payload) =>
  NonEmptyMap AccountAddress (Mismatch rel payload) ->
  Value
renderIncompleteWithdrawals :: forall (rel :: Relation) payload.
(Typeable rel, Show payload) =>
NonEmptyMap AccountAddress (Mismatch rel payload) -> Value
renderIncompleteWithdrawals NonEmptyMap AccountAddress (Mismatch rel payload)
payload =
  [(Key, Value)] -> Value
Aeson.object ([(Key, Value)] -> Value) -> [(Key, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ ((AccountAddress, Mismatch rel payload) -> (Key, Value))
-> [(AccountAddress, Mismatch rel payload)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (AccountAddress, Mismatch rel payload) -> (Key, Value)
forall {e} {kv} {a}.
(KeyValue e kv, Show a) =>
(AccountAddress, a) -> kv
renderTuple ([(AccountAddress, Mismatch rel payload)] -> [(Key, Value)])
-> [(AccountAddress, Mismatch rel payload)] -> [(Key, Value)]
forall a b. (a -> b) -> a -> b
$ NonEmptyMap AccountAddress (Mismatch rel payload)
-> [(AccountAddress, Mismatch rel payload)]
forall k v. NonEmptyMap k v -> [(k, v)]
NonEmptyMap.toList NonEmptyMap AccountAddress (Mismatch rel payload)
payload
 where
  renderTuple :: (AccountAddress, a) -> kv
renderTuple (AccountAddress
address, a
mismatch) =
    Text -> Key
Aeson.fromText (AccountAddress -> Text
renderRewardAccount AccountAddress
address) Key -> [Char] -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a -> [Char]
forall a. Show a => a -> [Char]
show a
mismatch