{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Shelley.Binary.Annotator (
  module Test.Cardano.Ledger.Core.Binary.Annotator,
) where

import Cardano.Ledger.BaseTypes (maybeToStrictMaybe)
import Cardano.Ledger.Binary
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Core
import Cardano.Ledger.MemoBytes (decodeMemoized)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.BlockChain
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
import Cardano.Ledger.Shelley.TxAuxData
import Cardano.Ledger.Shelley.TxBody
import Cardano.Ledger.Shelley.TxWits hiding (mapTraverseableDecoderA)
import Data.Functor.Identity (Identity (..))
import Data.IntMap
import qualified Data.MapExtras as Map (fromElems)
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as StrictSeq
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Binary.Annotator
import Test.Cardano.Ledger.Shelley.Arbitrary ()

instance
  ( EraTx era
  , DecCBOR (TxBody era)
  , DecCBOR (TxAuxData era)
  , DecCBOR (TxWits era)
  ) =>
  DecCBOR (ShelleyTxSeq era)
  where
  decCBOR :: forall s. Decoder s (ShelleyTxSeq era)
decCBOR = do
    Annotated Seq (TxBody era)
bodies ByteString
bodiesBytes <- Decoder s (Seq (TxBody era))
-> Decoder s (Annotated (Seq (TxBody era)) ByteString)
forall s a. Decoder s a -> Decoder s (Annotated a ByteString)
decodeAnnotated Decoder s (Seq (TxBody era))
forall s. Decoder s (Seq (TxBody era))
forall a s. DecCBOR a => Decoder s a
decCBOR
    Annotated Seq (TxWits era)
wits ByteString
witsBytes <- Decoder s (Seq (TxWits era))
-> Decoder s (Annotated (Seq (TxWits era)) ByteString)
forall s a. Decoder s a -> Decoder s (Annotated a ByteString)
decodeAnnotated Decoder s (Seq (TxWits era))
forall s. Decoder s (Seq (TxWits era))
forall a s. DecCBOR a => Decoder s a
decCBOR
    Annotated (IntMap (TxAuxData era)
auxDataMap :: IntMap (TxAuxData era)) ByteString
auxDataBytes <- Decoder s (IntMap (TxAuxData era))
-> Decoder s (Annotated (IntMap (TxAuxData era)) ByteString)
forall s a. Decoder s a -> Decoder s (Annotated a ByteString)
decodeAnnotated Decoder s (IntMap (TxAuxData era))
forall s. Decoder s (IntMap (TxAuxData era))
forall a s. DecCBOR a => Decoder s a
decCBOR
    let bodiesLength :: Int
bodiesLength = Seq (TxBody era) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (TxBody era)
bodies
    Seq (Maybe (TxAuxData era))
auxData <-
      (Maybe (Identity (TxAuxData era)) -> Maybe (TxAuxData era))
-> Seq (Maybe (Identity (TxAuxData era)))
-> Seq (Maybe (TxAuxData era))
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Identity (TxAuxData era) -> TxAuxData era)
-> Maybe (Identity (TxAuxData era)) -> Maybe (TxAuxData era)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity (TxAuxData era) -> TxAuxData era
forall a. Identity a -> a
runIdentity)
        (Seq (Maybe (Identity (TxAuxData era)))
 -> Seq (Maybe (TxAuxData era)))
-> Decoder s (Seq (Maybe (Identity (TxAuxData era))))
-> Decoder s (Seq (Maybe (TxAuxData era)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> IntMap (Identity (TxAuxData era))
-> Decoder s (Seq (Maybe (Identity (TxAuxData era))))
forall a s. Int -> IntMap a -> Decoder s (Seq (Maybe a))
auxDataSeqDecoder Int
bodiesLength ((TxAuxData era -> Identity (TxAuxData era))
-> IntMap (TxAuxData era) -> IntMap (Identity (TxAuxData era))
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxAuxData era -> Identity (TxAuxData era)
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntMap (TxAuxData era)
auxDataMap)

    let witsLength :: Int
witsLength = Seq (TxWits era) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (TxWits era)
wits
    Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
      (Int
bodiesLength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
witsLength)
      ( String -> Decoder s ()
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s ()) -> String -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
          String
"different number of transaction bodies ("
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
bodiesLength
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") and witness sets ("
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
witsLength
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
      )
    let txs :: StrictSeq (ShelleyTx era)
txs =
          Seq (ShelleyTx era) -> StrictSeq (ShelleyTx era)
forall a. Seq a -> StrictSeq a
StrictSeq.forceToStrict (Seq (ShelleyTx era) -> StrictSeq (ShelleyTx era))
-> Seq (ShelleyTx era) -> StrictSeq (ShelleyTx era)
forall a b. (a -> b) -> a -> b
$
            (TxBody era
 -> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era)
-> Seq (TxBody era)
-> Seq (TxWits era)
-> Seq (StrictMaybe (TxAuxData era))
-> Seq (ShelleyTx era)
forall a b c d.
(a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
Seq.zipWith3 TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
forall era.
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx Seq (TxBody era)
bodies Seq (TxWits era)
wits (Maybe (TxAuxData era) -> StrictMaybe (TxAuxData era)
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe (Maybe (TxAuxData era) -> StrictMaybe (TxAuxData era))
-> Seq (Maybe (TxAuxData era)) -> Seq (StrictMaybe (TxAuxData era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Maybe (TxAuxData era))
auxData)
    ShelleyTxSeq era -> Decoder s (ShelleyTxSeq era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyTxSeq era -> Decoder s (ShelleyTxSeq era))
-> ShelleyTxSeq era -> Decoder s (ShelleyTxSeq era)
forall a b. (a -> b) -> a -> b
$ StrictSeq (ShelleyTx era)
-> ByteString -> ByteString -> ByteString -> ShelleyTxSeq era
forall era.
StrictSeq (ShelleyTx era)
-> ByteString -> ByteString -> ByteString -> ShelleyTxSeq era
TxSeq' StrictSeq (ShelleyTx era)
txs ByteString
bodiesBytes ByteString
witsBytes ByteString
auxDataBytes

deriving newtype instance DecCBOR (TxBody ShelleyEra)

deriving newtype instance Era era => DecCBOR (ShelleyTxAuxData era)

instance (EraScript era, DecCBOR (Script era)) => DecCBOR (ShelleyTxWitsRaw era) where
  decCBOR :: forall s. Decoder s (ShelleyTxWitsRaw era)
decCBOR =
    Decode ('Closed 'Dense) (ShelleyTxWitsRaw era)
-> Decoder s (ShelleyTxWitsRaw era)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) (ShelleyTxWitsRaw era)
 -> Decoder s (ShelleyTxWitsRaw era))
-> Decode ('Closed 'Dense) (ShelleyTxWitsRaw era)
-> Decoder s (ShelleyTxWitsRaw era)
forall a b. (a -> b) -> a -> b
$
      String
-> ShelleyTxWitsRaw era
-> (Word -> Field (ShelleyTxWitsRaw era))
-> [(Word, String)]
-> Decode ('Closed 'Dense) (ShelleyTxWitsRaw era)
forall t.
Typeable t =>
String
-> t
-> (Word -> Field t)
-> [(Word, String)]
-> Decode ('Closed 'Dense) t
SparseKeyed
        String
"ShelleyTxWits"
        (Set (WitVKey 'Witness)
-> Map ScriptHash (Script era)
-> Set BootstrapWitness
-> ShelleyTxWitsRaw era
forall era.
Set (WitVKey 'Witness)
-> Map ScriptHash (Script era)
-> Set BootstrapWitness
-> ShelleyTxWitsRaw era
ShelleyTxWitsRaw Set (WitVKey 'Witness)
forall a. Monoid a => a
mempty Map ScriptHash (Script era)
forall a. Monoid a => a
mempty Set BootstrapWitness
forall a. Monoid a => a
mempty)
        Word -> Field (ShelleyTxWitsRaw era)
witField
        []
    where
      witField :: Word -> Field (ShelleyTxWitsRaw era)
      witField :: Word -> Field (ShelleyTxWitsRaw era)
witField Word
0 = (Set (WitVKey 'Witness)
 -> ShelleyTxWitsRaw era -> ShelleyTxWitsRaw era)
-> Decode ('Closed Any) (Set (WitVKey 'Witness))
-> Field (ShelleyTxWitsRaw era)
forall x t (d :: Density).
Typeable x =>
(x -> t -> t) -> Decode ('Closed d) x -> Field t
field (\Set (WitVKey 'Witness)
x ShelleyTxWitsRaw era
wits -> ShelleyTxWitsRaw era
wits {stwrAddrTxWits = x}) Decode ('Closed Any) (Set (WitVKey 'Witness))
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      witField Word
1 =
        (Map ScriptHash (Script era)
 -> ShelleyTxWitsRaw era -> ShelleyTxWitsRaw era)
-> Decode ('Closed 'Dense) (Map ScriptHash (Script era))
-> Field (ShelleyTxWitsRaw era)
forall x t (d :: Density).
Typeable x =>
(x -> t -> t) -> Decode ('Closed d) x -> Field t
field
          (\Map ScriptHash (Script era)
x ShelleyTxWitsRaw era
wits -> ShelleyTxWitsRaw era
wits {stwrScriptTxWits = x})
          ((forall s. Decoder s (Map ScriptHash (Script era)))
-> Decode ('Closed 'Dense) (Map ScriptHash (Script era))
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D ((forall s. Decoder s (Map ScriptHash (Script era)))
 -> Decode ('Closed 'Dense) (Map ScriptHash (Script era)))
-> (forall s. Decoder s (Map ScriptHash (Script era)))
-> Decode ('Closed 'Dense) (Map ScriptHash (Script era))
forall a b. (a -> b) -> a -> b
$ (Script era -> ScriptHash)
-> [Script era] -> Map ScriptHash (Script era)
forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
Map.fromElems (forall era. EraScript era => Script era -> ScriptHash
hashScript @era) ([Script era] -> Map ScriptHash (Script era))
-> Decoder s [Script era]
-> Decoder s (Map ScriptHash (Script era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Script era) -> Decoder s [Script era]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s (Script era)
forall s. Decoder s (Script era)
forall a s. DecCBOR a => Decoder s a
decCBOR)
      witField Word
2 = (Set BootstrapWitness
 -> ShelleyTxWitsRaw era -> ShelleyTxWitsRaw era)
-> Decode ('Closed Any) (Set BootstrapWitness)
-> Field (ShelleyTxWitsRaw era)
forall x t (d :: Density).
Typeable x =>
(x -> t -> t) -> Decode ('Closed d) x -> Field t
field (\Set BootstrapWitness
x ShelleyTxWitsRaw era
wits -> ShelleyTxWitsRaw era
wits {stwrBootAddrTxWits = x}) Decode ('Closed Any) (Set BootstrapWitness)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      witField Word
n = Word -> Field (ShelleyTxWitsRaw era)
forall t. Word -> Field t
invalidField Word
n

instance (EraScript era, DecCBOR (Script era)) => DecCBOR (ShelleyTxWits era) where
  decCBOR :: forall s. Decoder s (ShelleyTxWits era)
decCBOR = MemoBytes (ShelleyTxWitsRaw era) -> ShelleyTxWits era
forall era. MemoBytes (ShelleyTxWitsRaw era) -> ShelleyTxWits era
MkShelleyTxWits (MemoBytes (ShelleyTxWitsRaw era) -> ShelleyTxWits era)
-> Decoder s (MemoBytes (ShelleyTxWitsRaw era))
-> Decoder s (ShelleyTxWits era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (ShelleyTxWitsRaw era)
-> Decoder s (MemoBytes (ShelleyTxWitsRaw era))
forall s t. Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized Decoder s (ShelleyTxWitsRaw era)
forall s. Decoder s (ShelleyTxWitsRaw era)
forall a s. DecCBOR a => Decoder s a
decCBOR

instance Era era => DecCBOR (MultiSig era) where
  decCBOR :: forall s. Decoder s (MultiSig era)
decCBOR = MemoBytes (MultiSigRaw era) -> MultiSig era
forall era. MemoBytes (MultiSigRaw era) -> MultiSig era
MkMultiSig (MemoBytes (MultiSigRaw era) -> MultiSig era)
-> Decoder s (MemoBytes (MultiSigRaw era))
-> Decoder s (MultiSig era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (MultiSigRaw era)
-> Decoder s (MemoBytes (MultiSigRaw era))
forall s t. Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized Decoder s (MultiSigRaw era)
forall s. Decoder s (MultiSigRaw era)
forall a s. DecCBOR a => Decoder s a
decCBOR

instance Era era => DecCBOR (MultiSigRaw era) where
  decCBOR :: forall s. Decoder s (MultiSigRaw era)
decCBOR = Text
-> (Word -> Decoder s (Int, MultiSigRaw era))
-> Decoder s (MultiSigRaw era)
forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
"MultiSig" ((Word -> Decoder s (Int, MultiSigRaw era))
 -> Decoder s (MultiSigRaw era))
-> (Word -> Decoder s (Int, MultiSigRaw era))
-> Decoder s (MultiSigRaw era)
forall a b. (a -> b) -> a -> b
$ do
    \case
      Word
0 -> (,) Int
2 (MultiSigRaw era -> (Int, MultiSigRaw era))
-> (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> MultiSigRaw era)
-> Hash ADDRHASH (VerKeyDSIGN DSIGN)
-> (Int, MultiSigRaw era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash 'Witness -> MultiSigRaw era
forall era. KeyHash 'Witness -> MultiSigRaw era
MultiSigSignature (KeyHash 'Witness -> MultiSigRaw era)
-> (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash 'Witness)
-> Hash ADDRHASH (VerKeyDSIGN DSIGN)
-> MultiSigRaw era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash 'Witness
forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
KeyHash (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> (Int, MultiSigRaw era))
-> Decoder s (Hash ADDRHASH (VerKeyDSIGN DSIGN))
-> Decoder s (Int, MultiSigRaw era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Hash ADDRHASH (VerKeyDSIGN DSIGN))
forall s. Decoder s (Hash ADDRHASH (VerKeyDSIGN DSIGN))
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word
1 -> (,) Int
2 (MultiSigRaw era -> (Int, MultiSigRaw era))
-> (StrictSeq (MultiSig era) -> MultiSigRaw era)
-> StrictSeq (MultiSig era)
-> (Int, MultiSigRaw era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (MultiSig era) -> MultiSigRaw era
forall era. StrictSeq (MultiSig era) -> MultiSigRaw era
MultiSigAllOf (StrictSeq (MultiSig era) -> (Int, MultiSigRaw era))
-> Decoder s (StrictSeq (MultiSig era))
-> Decoder s (Int, MultiSigRaw era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (StrictSeq (MultiSig era))
forall s. Decoder s (StrictSeq (MultiSig era))
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word
2 -> (,) Int
2 (MultiSigRaw era -> (Int, MultiSigRaw era))
-> (StrictSeq (MultiSig era) -> MultiSigRaw era)
-> StrictSeq (MultiSig era)
-> (Int, MultiSigRaw era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (MultiSig era) -> MultiSigRaw era
forall era. StrictSeq (MultiSig era) -> MultiSigRaw era
MultiSigAnyOf (StrictSeq (MultiSig era) -> (Int, MultiSigRaw era))
-> Decoder s (StrictSeq (MultiSig era))
-> Decoder s (Int, MultiSigRaw era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (StrictSeq (MultiSig era))
forall s. Decoder s (StrictSeq (MultiSig era))
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word
3 -> (,) Int
3 (MultiSigRaw era -> (Int, MultiSigRaw era))
-> Decoder s (MultiSigRaw era) -> Decoder s (Int, MultiSigRaw era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> StrictSeq (MultiSig era) -> MultiSigRaw era
forall era. Int -> StrictSeq (MultiSig era) -> MultiSigRaw era
MultiSigMOf (Int -> StrictSeq (MultiSig era) -> MultiSigRaw era)
-> Decoder s Int
-> Decoder s (StrictSeq (MultiSig era) -> MultiSigRaw era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Int
forall s. Decoder s Int
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (StrictSeq (MultiSig era) -> MultiSigRaw era)
-> Decoder s (StrictSeq (MultiSig era))
-> Decoder s (MultiSigRaw era)
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 (StrictSeq (MultiSig era))
forall s. Decoder s (StrictSeq (MultiSig era))
forall a s. DecCBOR a => Decoder s a
decCBOR)
      Word
k -> Word -> Decoder s (Int, MultiSigRaw era)
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
k