{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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 (
  mapTraverseableDecoderA,
  module Test.Cardano.Ledger.Core.Binary.Annotator,
) where

import Cardano.Ledger.BaseTypes (maybeToStrictMaybe)
import Cardano.Ledger.Binary
import Cardano.Ledger.Binary.Coders
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.BlockChain
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.Shelley.Tx.Internal (
  ShelleyTx (MkShelleyTx),
  ShelleyTxRaw (..),
  unsafeConstructTxWithBytes,
 )
import Cardano.Ledger.Shelley.TxAuxData
import Cardano.Ledger.Shelley.TxBody
import Cardano.Ledger.Shelley.TxWits
import Data.MapExtras (fromElems)
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Data.Void
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Binary.Annotator
import Test.Cardano.Ledger.Shelley.Arbitrary ()

deriving via
  Mem (MultiSigRaw era)
  instance
    Era era => DecCBOR (Annotator (MultiSig era))

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

instance
  ( Era era
  , DecCBOR (PParamsUpdate era)
  , DecCBOR (TxOut era)
  , DecCBOR (TxCert era)
  ) =>
  DecCBOR (Annotator (ShelleyTxBodyRaw era))
  where
  decCBOR :: forall s. Decoder s (Annotator (ShelleyTxBodyRaw era))
decCBOR = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR

deriving via
  Mem (ShelleyTxBodyRaw era)
  instance
    EraTxBody era => DecCBOR (Annotator (ShelleyTxBody era))

instance Era era => DecCBOR (Annotator (ShelleyTxAuxDataRaw era)) where
  decCBOR :: forall s. Decoder s (Annotator (ShelleyTxAuxDataRaw era))
decCBOR = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR

deriving via
  Mem (ShelleyTxAuxDataRaw era)
  instance
    Era era => DecCBOR (Annotator (ShelleyTxAuxData era))

instance
  (EraScript era, DecCBOR (Annotator (Script era))) =>
  DecCBOR (Annotator (ShelleyTxWitsRaw era))
  where
  decCBOR :: forall s. Decoder s (Annotator (ShelleyTxWitsRaw era))
decCBOR = forall era s.
(EraScript era, DecCBOR (Annotator (Script era))) =>
Decoder s (Annotator (ShelleyTxWitsRaw era))
decodeWits

deriving via
  Mem (ShelleyTxWitsRaw era)
  instance
    ( EraScript era
    , DecCBOR (Annotator (Script era))
    ) =>
    DecCBOR (Annotator (ShelleyTxWits era))

decodeWits ::
  forall era s.
  (EraScript era, DecCBOR (Annotator (Script era))) =>
  Decoder s (Annotator (ShelleyTxWitsRaw era))
decodeWits :: forall era s.
(EraScript era, DecCBOR (Annotator (Script era))) =>
Decoder s (Annotator (ShelleyTxWitsRaw era))
decodeWits =
  forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$
    forall t.
Typeable t =>
String
-> t
-> (Word -> Field t)
-> [(Word, String)]
-> Decode ('Closed 'Dense) t
SparseKeyed
      String
"ShelleyTxWitsRaw"
      (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {era}. ShelleyTxWitsRaw era
emptyWitnessSet)
      Word -> Field (Annotator (ShelleyTxWitsRaw era))
witField
      []
  where
    emptyWitnessSet :: ShelleyTxWitsRaw era
emptyWitnessSet = forall era.
Set (WitVKey 'Witness)
-> Map ScriptHash (Script era)
-> Set BootstrapWitness
-> ShelleyTxWitsRaw era
ShelleyTxWitsRaw forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    witField :: Word -> Field (Annotator (ShelleyTxWitsRaw era))
    witField :: Word -> Field (Annotator (ShelleyTxWitsRaw era))
witField Word
0 =
      forall x (ann :: * -> *) t (d :: Density).
(Typeable x, Typeable ann, Applicative ann) =>
(x -> t -> t) -> Decode ('Closed d) (ann x) -> Field (ann t)
fieldAA
        (\Set (WitVKey 'Witness)
x ShelleyTxWitsRaw era
wits -> ShelleyTxWitsRaw era
wits {stwrAddrTxWits :: Set (WitVKey 'Witness)
stwrAddrTxWits = Set (WitVKey 'Witness)
x})
        (forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) s a (m :: * -> *) b.
Traversable f =>
Decoder s (f (Annotator a))
-> (f a -> m b) -> Decoder s (Annotator (m b))
mapTraverseableDecoderA (forall s a. Decoder s a -> Decoder s [a]
decodeList forall a s. DecCBOR a => Decoder s a
decCBOR) forall a. Ord a => [a] -> Set a
Set.fromList)
    witField Word
1 =
      forall x (ann :: * -> *) t (d :: Density).
(Typeable x, Typeable ann, Applicative ann) =>
(x -> t -> t) -> Decode ('Closed d) (ann x) -> Field (ann t)
fieldAA
        (\Map ScriptHash (Script era)
x ShelleyTxWitsRaw era
wits -> ShelleyTxWitsRaw era
wits {stwrScriptTxWits :: Map ScriptHash (Script era)
stwrScriptTxWits = Map ScriptHash (Script era)
x})
        ( forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) s a (m :: * -> *) b.
Traversable f =>
Decoder s (f (Annotator a))
-> (f a -> m b) -> Decoder s (Annotator (m b))
mapTraverseableDecoderA
              (forall s a. Decoder s a -> Decoder s [a]
decodeList forall a s. DecCBOR a => Decoder s a
decCBOR)
              (forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems (forall era. EraScript era => Script era -> ScriptHash
hashScript @era))
        )
    witField Word
2 =
      forall x (ann :: * -> *) t (d :: Density).
(Typeable x, Typeable ann, Applicative ann) =>
(x -> t -> t) -> Decode ('Closed d) (ann x) -> Field (ann t)
fieldAA
        (\Set BootstrapWitness
x ShelleyTxWitsRaw era
wits -> ShelleyTxWitsRaw era
wits {stwrBootAddrTxWits :: Set BootstrapWitness
stwrBootAddrTxWits = Set BootstrapWitness
x})
        (forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) s a (m :: * -> *) b.
Traversable f =>
Decoder s (f (Annotator a))
-> (f a -> m b) -> Decoder s (Annotator (m b))
mapTraverseableDecoderA (forall s a. Decoder s a -> Decoder s [a]
decodeList forall a s. DecCBOR a => Decoder s a
decCBOR) forall a. Ord a => [a] -> Set a
Set.fromList)
    witField Word
n = forall x (ann :: * -> *) t (d :: Density).
(Typeable x, Typeable ann, Applicative ann) =>
(x -> t -> t) -> Decode ('Closed d) (ann x) -> Field (ann t)
fieldAA (\(Void
_ :: Void) ShelleyTxWitsRaw era
wits -> ShelleyTxWitsRaw era
wits) (forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n)

mapTraverseableDecoderA ::
  Traversable f =>
  Decoder s (f (Annotator a)) ->
  (f a -> m b) ->
  Decoder s (Annotator (m b))
mapTraverseableDecoderA :: forall (f :: * -> *) s a (m :: * -> *) b.
Traversable f =>
Decoder s (f (Annotator a))
-> (f a -> m b) -> Decoder s (Annotator (m b))
mapTraverseableDecoderA Decoder s (f (Annotator a))
decList f a -> m b
transformList = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> m b
transformList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (f (Annotator a))
decList

deriving via
  Mem (ShelleyTxRaw era)
  instance
    ( EraTx era
    , DecCBOR (Annotator (TxBody era))
    , DecCBOR (Annotator (TxWits era))
    , DecCBOR (Annotator (TxAuxData era))
    ) =>
    DecCBOR (Annotator (ShelleyTx era))

instance
  ( EraTx era
  , DecCBOR (Annotator (TxBody era))
  , DecCBOR (Annotator (TxWits era))
  , DecCBOR (Annotator (TxAuxData era))
  ) =>
  DecCBOR (Annotator (ShelleyTxRaw era))
  where
  decCBOR :: forall s. Decoder s (Annotator (ShelleyTxRaw era))
decCBOR =
    forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$
      forall t1 (w :: Wrapped).
Typeable t1 =>
Decode w t1 -> Decode w (Annotator t1)
Ann (forall t. t -> Decode ('Closed 'Dense) t
RecD forall era.
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTxRaw era
ShelleyTxRaw)
        forall a t (w1 :: Wrapped) (d :: Density).
(Typeable a, Typeable t) =>
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall a t (w1 :: Wrapped) (d :: Density).
(Typeable a, Typeable t) =>
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall a t (w1 :: Wrapped) (d :: Density).
(Typeable a, Typeable t) =>
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D
          ( forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. Decoder s a -> Decoder s (Maybe a)
decodeNullMaybe forall a s. DecCBOR a => Decoder s a
decCBOR
          )

segWitAnnTx ::
  forall era.
  EraTx era =>
  Annotator (TxBody era) ->
  Annotator (TxWits era) ->
  Maybe (Annotator (TxAuxData era)) ->
  Annotator (ShelleyTx era)
segWitAnnTx :: forall era.
EraTx era =>
Annotator (TxBody era)
-> Annotator (TxWits era)
-> Maybe (Annotator (TxAuxData era))
-> Annotator (ShelleyTx era)
segWitAnnTx Annotator (TxBody era)
bodyAnn Annotator (TxWits era)
witsAnn Maybe (Annotator (TxAuxData era))
metaAnn = forall a. (FullByteString -> a) -> Annotator a
Annotator forall a b. (a -> b) -> a -> b
$ \FullByteString
bytes ->
  let body' :: TxBody era
body' = forall a. Annotator a -> FullByteString -> a
runAnnotator Annotator (TxBody era)
bodyAnn FullByteString
bytes
      witnessSet :: TxWits era
witnessSet = forall a. Annotator a -> FullByteString -> a
runAnnotator Annotator (TxWits era)
witsAnn FullByteString
bytes
      metadata :: Maybe (TxAuxData era)
metadata = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Annotator a -> FullByteString -> a
runAnnotator FullByteString
bytes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Annotator (TxAuxData era))
metaAnn
      wrappedMetadataBytes :: ByteString
wrappedMetadataBytes = case Maybe (TxAuxData era)
metadata of
        Maybe (TxAuxData era)
Nothing -> forall a. ToCBOR a => a -> ByteString
Plain.serialize Encoding
Plain.encodeNull
        Just TxAuxData era
b -> forall a. ToCBOR a => a -> ByteString
Plain.serialize TxAuxData era
b
      fullBytes :: ByteString
fullBytes =
        forall a. ToCBOR a => a -> ByteString
Plain.serialize (Word -> Encoding
Plain.encodeListLen Word
3)
          forall a. Semigroup a => a -> a -> a
<> forall a. ToCBOR a => a -> ByteString
Plain.serialize TxBody era
body'
          forall a. Semigroup a => a -> a -> a
<> forall a. ToCBOR a => a -> ByteString
Plain.serialize TxWits era
witnessSet
          forall a. Semigroup a => a -> a -> a
<> ByteString
wrappedMetadataBytes
   in forall era.
TxBody era
-> TxWits era
-> StrictMaybe (TxAuxData era)
-> ByteString
-> ShelleyTx era
unsafeConstructTxWithBytes
        TxBody era
body'
        TxWits era
witnessSet
        (forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe Maybe (TxAuxData era)
metadata)
        ByteString
fullBytes

-- | The parts of the Tx in Blocks that have to have DecCBOR(Annotator x) instances.
--   These are exactly the parts that are SafeToHash.
-- | Decode a TxSeq, used in decoding a Block.
txSeqDecoder ::
  ( EraTx era
  , DecCBOR (Annotator (TxAuxData era))
  , DecCBOR (Annotator (TxBody era))
  , DecCBOR (Annotator (TxWits era))
  ) =>
  Bool ->
  Decoder s (Annotator (ShelleyTxSeq era))
txSeqDecoder :: forall era s.
(EraTx era, DecCBOR (Annotator (TxAuxData era)),
 DecCBOR (Annotator (TxBody era)),
 DecCBOR (Annotator (TxWits era))) =>
Bool -> Decoder s (Annotator (ShelleyTxSeq era))
txSeqDecoder Bool
lax = do
  (Seq (Annotator (TxBody era))
bodies, Annotator ByteString
bodiesAnn) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall a s. DecCBOR a => Decoder s a
decCBOR
  (Seq (Annotator (TxWits era))
wits, Annotator ByteString
witsAnn) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall a s. DecCBOR a => Decoder s a
decCBOR
  let bodiesLength :: Int
bodiesLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (Annotator (TxBody era))
bodies
      witsLength :: Int
witsLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (Annotator (TxWits era))
wits
  (Seq (Maybe (Annotator (TxAuxData era)))
metadata, Annotator ByteString
metadataAnn) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall a b. (a -> b) -> a -> b
$ do
    IntMap (Annotator (TxAuxData era))
auxDataMap <- forall a s. DecCBOR a => Decoder s a
decCBOR
    forall a s. Int -> IntMap a -> Bool -> Decoder s (Seq (Maybe a))
auxDataSeqDecoder Int
bodiesLength IntMap (Annotator (TxAuxData era))
auxDataMap Bool
lax

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    (Bool
lax Bool -> Bool -> Bool
|| Int
bodiesLength forall a. Eq a => a -> a -> Bool
== Int
witsLength)
    ( forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
        String
"different number of transaction bodies ("
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
bodiesLength
          forall a. Semigroup a => a -> a -> a
<> String
") and witness sets ("
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
witsLength
          forall a. Semigroup a => a -> a -> a
<> String
")"
    )

  let txns :: Annotator (StrictSeq (ShelleyTx era))
txns =
        forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall a b. (a -> b) -> a -> b
$
          forall a. Seq a -> StrictSeq a
StrictSeq.forceToStrict forall a b. (a -> b) -> a -> b
$
            forall a b c d.
(a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
Seq.zipWith3 forall era.
EraTx era =>
Annotator (TxBody era)
-> Annotator (TxWits era)
-> Maybe (Annotator (TxAuxData era))
-> Annotator (ShelleyTx era)
segWitAnnTx Seq (Annotator (TxBody era))
bodies Seq (Annotator (TxWits era))
wits Seq (Maybe (Annotator (TxAuxData era)))
metadata
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
StrictSeq (ShelleyTx era)
-> ByteString -> ByteString -> ByteString -> ShelleyTxSeq era
TxSeq' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator (StrictSeq (ShelleyTx era))
txns forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
bodiesAnn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
witsAnn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
metadataAnn

instance
  ( EraTx era
  , DecCBOR (Annotator (TxAuxData era))
  , DecCBOR (Annotator (TxBody era))
  , DecCBOR (Annotator (TxWits era))
  ) =>
  DecCBOR (Annotator (ShelleyTxSeq era))
  where
  decCBOR :: forall s. Decoder s (Annotator (ShelleyTxSeq era))
decCBOR = forall era s.
(EraTx era, DecCBOR (Annotator (TxAuxData era)),
 DecCBOR (Annotator (TxBody era)),
 DecCBOR (Annotator (TxWits era))) =>
Bool -> Decoder s (Annotator (ShelleyTxSeq era))
txSeqDecoder Bool
False