{-# 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.Base.Typeable (TypeName (TypeName))
import Cardano.Ledger.BaseTypes (maybeToStrictMaybe)
import Cardano.Ledger.Binary
import Cardano.Ledger.Core
import Cardano.Ledger.MemoBytes (decodeMemoized)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.BlockBody.Internal
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..), Tx (..))
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 Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Binary.Annotator
import Test.Cardano.Ledger.Shelley.Arbitrary ()

instance
  ( EraTx era
  , DecCBOR (TxBody TopTx era)
  , DecCBOR (TxAuxData era)
  , DecCBOR (TxWits era)
  ) =>
  DecCBOR (ShelleyBlockBody era)
  where
  decCBOR :: forall s. Decoder s (ShelleyBlockBody era)
decCBOR = do
    Annotated bodies bodiesBytes <- Decoder s (Seq (TxBody TopTx era))
-> Decoder s (Annotated (Seq (TxBody TopTx era)) ByteString)
forall s a. Decoder s a -> Decoder s (Annotated a ByteString)
decodeAnnotated Decoder s (Seq (TxBody TopTx era))
forall s. Decoder s (Seq (TxBody TopTx era))
forall a s. DecCBOR a => Decoder s a
decCBOR
    Annotated wits witsBytes <- decodeAnnotated decCBOR
    Annotated (auxDataMap :: IntMap (TxAuxData era)) auxDataBytes <- decodeAnnotated decCBOR
    let bodiesLength = Seq (TxBody TopTx era) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (TxBody TopTx era)
bodies
    auxData <-
      fmap (fmap runIdentity)
        <$> auxDataSeqDecoder bodiesLength (fmap pure auxDataMap)
    let witsLength = Seq (TxWits era) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (TxWits era)
wits
    unless
      (bodiesLength == witsLength)
      ( fail $
          "different number of transaction bodies ("
            <> show bodiesLength
            <> ") and witness sets ("
            <> show witsLength
            <> ")"
      )
    let
      mkTx TxBody l era
body TxWits era
wit StrictMaybe (TxAuxData era)
aux =
        TxBody l era -> Tx l era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody l era
body
          Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx l era -> Identity (Tx l era))
-> TxWits era -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
wit
          Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
auxDataTxL ((StrictMaybe (TxAuxData era)
  -> Identity (StrictMaybe (TxAuxData era)))
 -> Tx l era -> Identity (Tx l era))
-> StrictMaybe (TxAuxData era) -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (TxAuxData era)
aux
      txs =
        Seq (Tx TopTx era) -> StrictSeq (Tx TopTx era)
forall a. Seq a -> StrictSeq a
StrictSeq.forceToStrict (Seq (Tx TopTx era) -> StrictSeq (Tx TopTx era))
-> Seq (Tx TopTx era) -> StrictSeq (Tx TopTx era)
forall a b. (a -> b) -> a -> b
$
          (TxBody TopTx era
 -> TxWits era -> StrictMaybe (TxAuxData era) -> Tx TopTx era)
-> Seq (TxBody TopTx era)
-> Seq (TxWits era)
-> Seq (StrictMaybe (TxAuxData era))
-> Seq (Tx TopTx era)
forall a b c d.
(a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
Seq.zipWith3 TxBody TopTx era
-> TxWits era -> StrictMaybe (TxAuxData era) -> Tx TopTx era
forall {era} {l :: TxLevel}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era) =>
TxBody l era
-> TxWits era -> StrictMaybe (TxAuxData era) -> Tx l era
mkTx Seq (TxBody TopTx 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)
      hash = ByteString
-> ByteString -> ByteString -> Hash HASH EraIndependentBlockBody
hashShelleySegWits ByteString
bodiesBytes ByteString
witsBytes ByteString
auxDataBytes
    pure $ ShelleyBlockBodyInternal txs hash bodiesBytes witsBytes auxDataBytes

instance
  ( Era era
  , DecCBOR (TxBody TopTx era)
  , DecCBOR (TxWits era)
  , DecCBOR (TxAuxData era)
  ) =>
  DecCBOR (ShelleyTx TopTx era)
  where
  decCBOR :: forall s. Decoder s (ShelleyTx TopTx era)
decCBOR =
    Text
-> (ShelleyTx TopTx era -> Int)
-> Decoder s (ShelleyTx TopTx era)
-> Decoder s (ShelleyTx TopTx era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ShelleyTx" (Int -> ShelleyTx TopTx era -> Int
forall a b. a -> b -> a
const Int
3) (Decoder s (ShelleyTx TopTx era)
 -> Decoder s (ShelleyTx TopTx era))
-> Decoder s (ShelleyTx TopTx era)
-> Decoder s (ShelleyTx TopTx era)
forall a b. (a -> b) -> a -> b
$
      TxBody TopTx era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era
forall era.
TxBody TopTx era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era
ShelleyTx
        (TxBody TopTx era
 -> TxWits era
 -> StrictMaybe (TxAuxData era)
 -> ShelleyTx TopTx era)
-> Decoder s (TxBody TopTx era)
-> Decoder
     s
     (TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (TxBody TopTx era)
forall s. Decoder s (TxBody TopTx era)
forall a s. DecCBOR a => Decoder s a
decCBOR
        Decoder
  s
  (TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era)
-> Decoder s (TxWits era)
-> Decoder s (StrictMaybe (TxAuxData era) -> ShelleyTx TopTx 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 (TxWits era)
forall s. Decoder s (TxWits era)
forall a s. DecCBOR a => Decoder s a
decCBOR
        Decoder s (StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era)
-> Decoder s (StrictMaybe (TxAuxData era))
-> Decoder s (ShelleyTx TopTx 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 (TxAuxData era)
-> Decoder s (StrictMaybe (TxAuxData era))
forall s a. Decoder s a -> Decoder s (StrictMaybe a)
decodeNullStrictMaybe Decoder s (TxAuxData era)
forall s. Decoder s (TxAuxData era)
forall a s. DecCBOR a => Decoder s a
decCBOR

deriving newtype instance DecCBOR (TxBody TopTx ShelleyEra)

deriving newtype instance DecCBOR (Tx TopTx 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 = TypeName (ShelleyTxWitsRaw era)
-> [(Word, String)]
-> ShelleyTxWitsRaw era
-> (ShelleyTxWitsRaw era
    -> Word -> Maybe (Decoder s (ShelleyTxWitsRaw era)))
-> Decoder s (ShelleyTxWitsRaw era)
forall a s.
TypeName a
-> [(Word, String)]
-> a
-> (a -> Word -> Maybe (Decoder s a))
-> Decoder s a
decodeSparseKeyed TypeName (ShelleyTxWitsRaw era)
forall a. Typeable a => TypeName a
TypeName [] (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) ShelleyTxWitsRaw era
-> Word -> Maybe (Decoder s (ShelleyTxWitsRaw era))
forall s.
ShelleyTxWitsRaw era
-> Word -> Maybe (Decoder s (ShelleyTxWitsRaw era))
decoderByKey
    where
      decoderByKey :: ShelleyTxWitsRaw era -> Word -> Maybe (Decoder s (ShelleyTxWitsRaw era))
      decoderByKey :: forall s.
ShelleyTxWitsRaw era
-> Word -> Maybe (Decoder s (ShelleyTxWitsRaw era))
decoderByKey ShelleyTxWitsRaw era
acc = \case
        Word
0 -> Decoder s (ShelleyTxWitsRaw era)
-> Maybe (Decoder s (ShelleyTxWitsRaw era))
forall a. a -> Maybe a
Just (Decoder s (ShelleyTxWitsRaw era)
 -> Maybe (Decoder s (ShelleyTxWitsRaw era)))
-> Decoder s (ShelleyTxWitsRaw era)
-> Maybe (Decoder s (ShelleyTxWitsRaw era))
forall a b. (a -> b) -> a -> b
$ do
          x <- Decoder s (Set (WitVKey Witness))
forall s. Decoder s (Set (WitVKey Witness))
forall a s. DecCBOR a => Decoder s a
decCBOR
          pure $ acc {stwrAddrTxWits = x}
        Word
1 -> Decoder s (ShelleyTxWitsRaw era)
-> Maybe (Decoder s (ShelleyTxWitsRaw era))
forall a. a -> Maybe a
Just (Decoder s (ShelleyTxWitsRaw era)
 -> Maybe (Decoder s (ShelleyTxWitsRaw era)))
-> Decoder s (ShelleyTxWitsRaw era)
-> Maybe (Decoder s (ShelleyTxWitsRaw era))
forall a b. (a -> b) -> a -> b
$ do
          x <- (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
          pure $ acc {stwrScriptTxWits = x}
        Word
2 -> Decoder s (ShelleyTxWitsRaw era)
-> Maybe (Decoder s (ShelleyTxWitsRaw era))
forall a. a -> Maybe a
Just (Decoder s (ShelleyTxWitsRaw era)
 -> Maybe (Decoder s (ShelleyTxWitsRaw era)))
-> Decoder s (ShelleyTxWitsRaw era)
-> Maybe (Decoder s (ShelleyTxWitsRaw era))
forall a b. (a -> b) -> a -> b
$ do
          x <- Decoder s (Set BootstrapWitness)
forall s. Decoder s (Set BootstrapWitness)
forall a s. DecCBOR a => Decoder s a
decCBOR
          pure $ acc {stwrBootAddrTxWits = x}
        Word
_ -> Maybe (Decoder s (ShelleyTxWitsRaw era))
forall a. Maybe a
Nothing
      {-# INLINE decoderByKey #-}

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