{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Shelley.Binary.Golden (
  goldenNewEpochStateExpectation,
  duplicateDelegCertsTxBody,
  shelleyDecodeDuplicateDelegCertSucceeds,
  module Test.Cardano.Ledger.Binary.Golden,
) where

import Cardano.Ledger.BaseTypes (BlocksMade (..), EpochNo (..), SlotNo (..))
import Cardano.Ledger.Binary (
  EncCBOR,
  ToCBOR (..),
  Tokens (..),
  Version,
  lengthThreshold,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.MemoBytes (EqRaw (..))
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.State
import Cardano.Ledger.TxIn (TxIn)
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import qualified Data.VMap as VMap
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Binary.Golden
import Test.Cardano.Ledger.Binary.Plain.Golden
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.KeyPair (mkKeyHash)
import Test.Cardano.Ledger.Shelley.Arbitrary ()
import Test.Cardano.Ledger.Shelley.Era (ShelleyEraTest)

duplicateDelegCertsTxBody :: forall era. ShelleyEraTest era => Version -> Enc
duplicateDelegCertsTxBody :: forall era. ShelleyEraTest era => Version -> Enc
duplicateDelegCertsTxBody Version
v =
  [Enc] -> Enc
forall a. Monoid a => [a] -> a
mconcat
    [ (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E ((Tokens -> Tokens) -> Enc) -> (Tokens -> Tokens) -> Enc
forall a b. (a -> b) -> a -> b
$ Word -> Tokens -> Tokens
TkMapLen Word
5
    , [Enc] -> Enc
Em [forall a. ToCBOR a => a -> Enc
E @Int Int
0, Version -> Set TxIn -> Enc
forall a. EncCBOR a => Version -> a -> Enc
Ev Version
v (Set TxIn -> Enc) -> Set TxIn -> Enc
forall a b. (a -> b) -> a -> b
$ forall a. Set a
Set.empty @TxIn]
    , [Enc] -> Enc
Em [forall a. ToCBOR a => a -> Enc
E @Int Int
1, Version -> [TxOut era] -> Enc
forall a. EncCBOR a => Version -> a -> Enc
Ev Version
v ([TxOut era] -> Enc) -> [TxOut era] -> Enc
forall a b. (a -> b) -> a -> b
$ [] @(TxOut era)]
    , [Enc] -> Enc
Em [forall a. ToCBOR a => a -> Enc
E @Int Int
2, Coin -> Enc
forall a. ToCBOR a => a -> Enc
E (Coin -> Enc) -> Coin -> Enc
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
0]
    , [Enc] -> Enc
Em [forall a. ToCBOR a => a -> Enc
E @Int Int
3, forall a. ToCBOR a => a -> Enc
E @Int Int
300]
    , [Enc] -> Enc
Em
        [ forall a. ToCBOR a => a -> Enc
E @Int Int
4
        , [Enc] -> Enc
Em
            [ (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E ((Tokens -> Tokens) -> Enc) -> (Tokens -> Tokens) -> Enc
forall a b. (a -> b) -> a -> b
$ Word -> Tokens -> Tokens
TkListLen Word
2
            , Enc
cert
            , Enc
cert
            ]
        ]
    ]
  where
    cert :: Enc
cert =
      [Enc] -> Enc
Em
        [ (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E ((Tokens -> Tokens) -> Enc) -> (Tokens -> Tokens) -> Enc
forall a b. (a -> b) -> a -> b
$ Word -> Tokens -> Tokens
TkListLen Word
3
        , forall a. ToCBOR a => a -> Enc
E @Int Int
2
        , Credential Staking -> Enc
forall a. ToCBOR a => a -> Enc
E (Credential Staking -> Enc)
-> (KeyHash Staking -> Credential Staking)
-> KeyHash Staking
-> Enc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Enc) -> KeyHash Staking -> Enc
forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). Int -> KeyHash kd
mkKeyHash @Staking Int
0
        , KeyHash StakePool -> Enc
forall a. ToCBOR a => a -> Enc
E (KeyHash StakePool -> Enc) -> KeyHash StakePool -> Enc
forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). Int -> KeyHash kd
mkKeyHash @StakePool Int
1
        ]

goldenNewEpochStateExpectation ::
  forall era.
  ( HasCallStack
  , EraTxOut era
  , EraGov era
  , EraStake era
  , ToCBOR (StashedAVVMAddresses era)
  , EncCBOR (StashedAVVMAddresses era)
  , EraCertState era
  ) =>
  NewEpochState era ->
  Expectation
goldenNewEpochStateExpectation :: forall era.
(HasCallStack, EraTxOut era, EraGov era, EraStake era,
 ToCBOR (StashedAVVMAddresses era),
 EncCBOR (StashedAVVMAddresses era), EraCertState era) =>
NewEpochState era -> Expectation
goldenNewEpochStateExpectation
  nes :: NewEpochState era
nes@NewEpochState
    { nesEs :: forall era. NewEpochState era -> EpochState era
nesEs =
      EpochState
        { esChainAccountState :: forall era. EpochState era -> ChainAccountState
esChainAccountState = ChainAccountState {Coin
casTreasury :: Coin
casReserves :: Coin
casReserves :: ChainAccountState -> Coin
casTreasury :: ChainAccountState -> Coin
..}
        , esSnapshots :: forall era. EpochState era -> SnapShots
esSnapshots = SnapShots {Coin
PoolDistr
SnapShot
ssStakeMark :: SnapShot
ssStakeMarkPoolDistr :: PoolDistr
ssStakeSet :: SnapShot
ssStakeGo :: SnapShot
ssFee :: Coin
ssFee :: SnapShots -> Coin
ssStakeGo :: SnapShots -> SnapShot
ssStakeSet :: SnapShots -> SnapShot
ssStakeMarkPoolDistr :: SnapShots -> PoolDistr
ssStakeMark :: SnapShots -> SnapShot
..}
        , NonMyopic
LedgerState era
esLState :: LedgerState era
esNonMyopic :: NonMyopic
esNonMyopic :: forall era. EpochState era -> NonMyopic
esLState :: forall era. EpochState era -> LedgerState era
..
        }
    , StrictMaybe PulsingRewUpdate
EpochNo
BlocksMade
PoolDistr
StashedAVVMAddresses era
nesEL :: EpochNo
nesBprev :: BlocksMade
nesBcur :: BlocksMade
nesRu :: StrictMaybe PulsingRewUpdate
nesPd :: PoolDistr
stashedAVVMAddresses :: StashedAVVMAddresses era
stashedAVVMAddresses :: forall era. NewEpochState era -> StashedAVVMAddresses era
nesPd :: forall era. NewEpochState era -> PoolDistr
nesRu :: forall era. NewEpochState era -> StrictMaybe PulsingRewUpdate
nesBcur :: forall era. NewEpochState era -> BlocksMade
nesBprev :: forall era. NewEpochState era -> BlocksMade
nesEL :: forall era. NewEpochState era -> EpochNo
..
    } =
    DiffView -> NewEpochState era -> Enc -> Expectation
forall a b.
(HasCallStack, ToCBOR a, ToCBOR b) =>
DiffView -> a -> b -> Expectation
expectGoldenToCBOR DiffView
DiffHex NewEpochState era
nes (Enc -> Expectation) -> Enc -> Expectation
forall a b. (a -> b) -> a -> b
$
      [Enc] -> Enc
forall a. Monoid a => [a] -> a
mconcat
        [ (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E (Word -> Tokens -> Tokens
TkListLen Word
7)
        , (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E (Word64 -> Tokens -> Tokens
TkWord64 (EpochNo -> Word64
unEpochNo EpochNo
nesEL))
        , Map (KeyHash StakePool) Natural -> Enc
forall {k} {a}. (EncCBOR k, EncCBOR a) => Map k a -> Enc
mapEnc (BlocksMade -> Map (KeyHash StakePool) Natural
unBlocksMade BlocksMade
nesBprev)
        , Map (KeyHash StakePool) Natural -> Enc
forall {k} {a}. (EncCBOR k, EncCBOR a) => Map k a -> Enc
mapEnc (BlocksMade -> Map (KeyHash StakePool) Natural
unBlocksMade BlocksMade
nesBcur)
        , [Enc] -> Enc
Em
            [ (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E (Word -> Tokens -> Tokens
TkListLen Word
4)
            , [Enc] -> Enc
Em
                [ (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E (Word -> Tokens -> Tokens
TkListLen Word
2)
                , Coin -> Enc
forall a. ToCBOR a => a -> Enc
E Coin
casTreasury
                , Coin -> Enc
forall a. ToCBOR a => a -> Enc
E Coin
casReserves
                ]
            , LedgerState era -> Enc
forall a. ToCBOR a => a -> Enc
E LedgerState era
esLState
            , [Enc] -> Enc
Em
                [ (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E (Word -> Tokens -> Tokens
TkListLen Word
4)
                , SnapShot -> Enc
snapShotEnc SnapShot
ssStakeMark
                , SnapShot -> Enc
snapShotEnc SnapShot
ssStakeSet
                , SnapShot -> Enc
snapShotEnc SnapShot
ssStakeGo
                , Coin -> Enc
forall a. ToCBOR a => a -> Enc
E Coin
ssFee
                ]
            , Version -> NonMyopic -> Enc
forall a. EncCBOR a => Version -> a -> Enc
Ev Version
ver NonMyopic
esNonMyopic
            ]
        , Version -> StrictMaybe PulsingRewUpdate -> Enc
forall a. EncCBOR a => Version -> a -> Enc
Ev Version
ver StrictMaybe PulsingRewUpdate
nesRu
        , Version -> PoolDistr -> Enc
forall a. EncCBOR a => Version -> a -> Enc
Ev Version
ver PoolDistr
nesPd
        , StashedAVVMAddresses era -> Enc
forall a. ToCBOR a => a -> Enc
E StashedAVVMAddresses era
stashedAVVMAddresses
        ]
    where
      ver :: Version
ver = forall era. Era era => Version
eraProtVerLow @era
      mapEnc :: Map k a -> Enc
mapEnc Map k a
m
        | Map k a -> Int
forall k a. Map k a -> Int
Map.size Map k a
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lengthThreshold =
            [Enc] -> Enc
Em [(Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E Tokens -> Tokens
TkMapBegin, Enc
me, (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E Tokens -> Tokens
TkBreak]
        | Bool
otherwise =
            [Enc] -> Enc
Em [(Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E (Word -> Tokens -> Tokens
TkMapLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map k a -> Int
forall k a. Map k a -> Int
Map.size Map k a
m))), Enc
me]
        where
          me :: Enc
me = [Enc] -> Enc
Em [Version -> k -> Enc
forall a. EncCBOR a => Version -> a -> Enc
Ev Version
ver k
k Enc -> Enc -> Enc
forall a. Semigroup a => a -> a -> a
<> Version -> a -> Enc
forall a. EncCBOR a => Version -> a -> Enc
Ev Version
ver a
v | (k
k, a
v) <- Map k a -> [(k, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k a
m]
      snapShotEnc :: SnapShot -> Enc
snapShotEnc SnapShot {Stake
VMap VB VB (KeyHash StakePool) StakePoolParams
VMap VB VB (Credential Staking) (KeyHash StakePool)
ssStake :: Stake
ssDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool)
ssPoolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams
ssPoolParams :: SnapShot -> VMap VB VB (KeyHash StakePool) StakePoolParams
ssDelegations :: SnapShot -> VMap VB VB (Credential Staking) (KeyHash StakePool)
ssStake :: SnapShot -> Stake
..} =
        [Enc] -> Enc
Em
          [ (Tokens -> Tokens) -> Enc
forall a. ToCBOR a => a -> Enc
E (Word -> Tokens -> Tokens
TkListLen Word
3)
          , Map (Credential Staking) (CompactForm Coin) -> Enc
forall {k} {a}. (EncCBOR k, EncCBOR a) => Map k a -> Enc
mapEnc (VMap VB VP (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap (Stake -> VMap VB VP (Credential Staking) (CompactForm Coin)
unStake Stake
ssStake))
          , Version
-> VMap VB VB (Credential Staking) (KeyHash StakePool) -> Enc
forall a. EncCBOR a => Version -> a -> Enc
Ev Version
ver VMap VB VB (Credential Staking) (KeyHash StakePool)
ssDelegations
          , Version -> VMap VB VB (KeyHash StakePool) StakePoolParams -> Enc
forall a. EncCBOR a => Version -> a -> Enc
Ev Version
ver VMap VB VB (KeyHash StakePool) StakePoolParams
ssPoolParams
          ]

shelleyDecodeDuplicateDelegCertSucceeds :: Version -> Spec
shelleyDecodeDuplicateDelegCertSucceeds :: Version -> Spec
shelleyDecodeDuplicateDelegCertSucceeds Version
version =
  String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Decodes duplicate delegation certificates successfully" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
    let testCert :: TxCert ShelleyEra
testCert = forall era.
ShelleyEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
DelegStakeTxCert @ShelleyEra (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> KeyHash Staking -> Credential Staking
forall a b. (a -> b) -> a -> b
$ Int -> KeyHash Staking
forall (kd :: KeyRole). Int -> KeyHash kd
mkKeyHash Int
0) (Int -> KeyHash StakePool
forall (kd :: KeyRole). Int -> KeyHash kd
mkKeyHash Int
1)
    (TxBody TopTx ShelleyEra -> TxBody TopTx ShelleyEra -> Bool)
-> Version -> Enc -> TxBody TopTx ShelleyEra -> Expectation
forall a.
(DecCBOR (Annotator a), HasCallStack, Show a, Eq a) =>
(a -> a -> Bool) -> Version -> Enc -> a -> Expectation
expectDecoderSuccessAnnWith TxBody TopTx ShelleyEra -> TxBody TopTx ShelleyEra -> Bool
forall a. EqRaw a => a -> a -> Bool
eqRaw Version
version (forall era. ShelleyEraTest era => Version -> Enc
duplicateDelegCertsTxBody @ShelleyEra Version
version) (TxBody TopTx ShelleyEra -> Expectation)
-> TxBody TopTx ShelleyEra -> Expectation
forall a b. (a -> b) -> a -> b
$
      forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
mkBasicTxBody @ShelleyEra @TopTx
        TxBody TopTx ShelleyEra
-> (TxBody TopTx ShelleyEra -> TxBody TopTx ShelleyEra)
-> TxBody TopTx ShelleyEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert ShelleyEra)
 -> Identity (StrictSeq (TxCert ShelleyEra)))
-> TxBody TopTx ShelleyEra -> Identity (TxBody TopTx ShelleyEra)
(StrictSeq (ShelleyTxCert ShelleyEra)
 -> Identity (StrictSeq (ShelleyTxCert ShelleyEra)))
-> TxBody TopTx ShelleyEra -> Identity (TxBody TopTx ShelleyEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l ShelleyEra) (StrictSeq (TxCert ShelleyEra))
certsTxBodyL ((StrictSeq (ShelleyTxCert ShelleyEra)
  -> Identity (StrictSeq (ShelleyTxCert ShelleyEra)))
 -> TxBody TopTx ShelleyEra -> Identity (TxBody TopTx ShelleyEra))
-> StrictSeq (ShelleyTxCert ShelleyEra)
-> TxBody TopTx ShelleyEra
-> TxBody TopTx ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ShelleyTxCert ShelleyEra] -> StrictSeq (ShelleyTxCert ShelleyEra)
forall a. [a] -> StrictSeq a
SSeq.fromList [ShelleyTxCert ShelleyEra
testCert, ShelleyTxCert ShelleyEra
testCert]
        TxBody TopTx ShelleyEra
-> (TxBody TopTx ShelleyEra -> TxBody TopTx ShelleyEra)
-> TxBody TopTx ShelleyEra
forall a b. a -> (a -> b) -> b
& (SlotNo -> Identity SlotNo)
-> TxBody TopTx ShelleyEra -> Identity (TxBody TopTx ShelleyEra)
forall era.
(ShelleyEraTxBody era, ExactEra ShelleyEra era) =>
Lens' (TxBody TopTx era) SlotNo
Lens' (TxBody TopTx ShelleyEra) SlotNo
ttlTxBodyL ((SlotNo -> Identity SlotNo)
 -> TxBody TopTx ShelleyEra -> Identity (TxBody TopTx ShelleyEra))
-> SlotNo -> TxBody TopTx ShelleyEra -> TxBody TopTx ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word64 -> SlotNo
SlotNo Word64
300