{-# 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.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 = Decode (Closed Dense) (ShelleyTx TopTx era) -> Decoder s (ShelleyTx TopTx era) forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t decode (Decode (Closed Dense) (ShelleyTx TopTx era) -> Decoder s (ShelleyTx TopTx era)) -> Decode (Closed Dense) (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) -> Decode (Closed Dense) (TxBody TopTx era -> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era) forall t. t -> Decode (Closed Dense) t RecD 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 Decode (Closed Dense) (TxBody TopTx era -> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era) -> Decode (Closed (ZonkAny 3)) (TxBody TopTx era) -> Decode (Closed Dense) (TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era) forall a (w1 :: Wrapped) t (w :: Density). Typeable a => Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t <! Decode (Closed (ZonkAny 3)) (TxBody TopTx era) forall t (w :: Wrapped). DecCBOR t => Decode w t From Decode (Closed Dense) (TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era) -> Decode (Closed (ZonkAny 2)) (TxWits era) -> Decode (Closed Dense) (StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era) forall a (w1 :: Wrapped) t (w :: Density). Typeable a => Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t <! Decode (Closed (ZonkAny 2)) (TxWits era) forall t (w :: Wrapped). DecCBOR t => Decode w t From Decode (Closed Dense) (StrictMaybe (TxAuxData era) -> ShelleyTx TopTx era) -> Decode (Closed Dense) (StrictMaybe (TxAuxData era)) -> Decode (Closed Dense) (ShelleyTx TopTx era) forall a (w1 :: Wrapped) t (w :: Density). Typeable a => Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t <! (forall s. Decoder s (StrictMaybe (TxAuxData era))) -> Decode (Closed Dense) (StrictMaybe (TxAuxData era)) forall t. (forall s. Decoder s t) -> Decode (Closed Dense) t D (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 = 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 (ZonkAny MinVersion)) (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 (ZonkAny MinVersion)) (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 (ZonkAny 1)) (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 (ZonkAny 1)) (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