{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.Ledger.Conway.Proposals where

import Cardano.Ledger.Conway
import Cardano.Ledger.Conway.Governance
import Control.DeepSeq (force)
import Control.Exception (AssertionFailed (..), evaluate)
import Data.Either (isRight)
import Data.Foldable as F (foldl', toList)
import qualified Data.Map.Strict as Map
import Data.MapExtras (fromElems)
import Data.Maybe (fromMaybe)
import Data.Sequence (fromList)
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Conway.Arbitrary (
  ProposalsForEnactment (..),
  ProposalsNewActions (..),
 )

spec :: Spec
spec :: Spec
spec = do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Proposals" forall a b. (a -> b) -> a -> b
$ do
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Construction" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Adding new nodes keeps Proposals consistent" forall a b. (a -> b) -> a -> b
$
        \(ProposalsNewActions Proposals Conway
ps [GovActionState Conway]
actions :: ProposalsNewActions Conway) ->
          let ps' :: Proposals Conway
ps' =
                forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl'
                  (\Proposals Conway
p GovActionState Conway
action -> forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Unable to add action") forall a b. (a -> b) -> a -> b
$ forall era.
(EraPParams era, HasCallStack) =>
GovActionState era -> Proposals era -> Maybe (Proposals era)
proposalsAddAction GovActionState Conway
action Proposals Conway
p)
                  Proposals Conway
ps
                  [GovActionState Conway]
actions
              actionsMap :: Map (GovActionId StandardCrypto) (GovActionState Conway)
actionsMap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (\Map (GovActionId StandardCrypto) (GovActionState Conway)
accum GovActionState Conway
gas -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId GovActionState Conway
gas) GovActionState Conway
gas Map (GovActionId StandardCrypto) (GovActionState Conway)
accum) forall k a. Map k a
Map.empty [GovActionState Conway]
actions
           in Map (GovActionId StandardCrypto) (GovActionState Conway)
actionsMap forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` (Map (GovActionId StandardCrypto) (GovActionState Conway)
actionsMap forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.intersection` forall era.
Proposals era
-> Map (GovActionId (EraCrypto era)) (GovActionState era)
proposalsActionsMap Proposals Conway
ps')
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Removal" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Removing leaf nodes keeps Proposals consistent" forall a b. (a -> b) -> a -> b
$
        \(Proposals Conway
ps :: Proposals Conway) -> do
          let gais :: Set (GovActionId StandardCrypto)
gais = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a. Int -> StrictSeq a -> StrictSeq a
SSeq.takeLast Int
4 forall a b. (a -> b) -> a -> b
$ forall era.
Proposals era -> StrictSeq (GovActionId (EraCrypto era))
proposalsIds Proposals Conway
ps
              ps' :: Proposals Conway
ps' = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveWithDescendants Set (GovActionId StandardCrypto)
gais Proposals Conway
ps
          forall era. Proposals era -> Int
proposalsSize Proposals Conway
ps' forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall era. Proposals era -> Int
proposalsSize Proposals Conway
ps forall a. Num a => a -> a -> a
- forall a. Set a -> Int
Set.size Set (GovActionId StandardCrypto)
gais
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Removing root nodes keeps Proposals consistent" forall a b. (a -> b) -> a -> b
$
        \(Proposals Conway
ps :: Proposals Conway) -> do
          let gais :: Set (GovActionId StandardCrypto)
gais = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a. Int -> StrictSeq a -> StrictSeq a
SSeq.take Int
4 forall a b. (a -> b) -> a -> b
$ forall era.
Proposals era -> StrictSeq (GovActionId (EraCrypto era))
proposalsIds Proposals Conway
ps
              ps' :: Proposals Conway
ps' = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveWithDescendants Set (GovActionId StandardCrypto)
gais Proposals Conway
ps
          forall era. Proposals era -> Int
proposalsSize Proposals Conway
ps' forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` (forall a. Ord a => a -> a -> Bool
<= forall era. Proposals era -> Int
proposalsSize Proposals Conway
ps)
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Removing non-member nodes throws an AssertionFailure" forall a b. (a -> b) -> a -> b
$
        \(ProposalsNewActions Proposals Conway
ps [GovActionState Conway]
actions :: ProposalsNewActions Conway) ->
          (forall a. a -> IO a
evaluate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NFData a => a -> a
force) (forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveWithDescendants (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GovActionState Conway]
actions) Proposals Conway
ps)
            forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \AssertionFailed {} -> Bool
True
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Enactment" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Adding votes preserves consistency" forall a b. (a -> b) -> a -> b
$
        \( ProposalsForEnactment {Proposals Conway
pfeProposals :: forall era. ProposalsForEnactment era -> Proposals era
pfeProposals :: Proposals Conway
pfeProposals, Seq (GovActionState Conway)
pfeToEnact :: forall era. ProposalsForEnactment era -> Seq (GovActionState era)
pfeToEnact :: Seq (GovActionState Conway)
pfeToEnact} :: ProposalsForEnactment Conway
          , Voter StandardCrypto
voter :: Voter era
          , Vote
vote :: Vote
          ) -> do
            case Seq (GovActionState Conway)
pfeToEnact of
              GovActionState Conway
gas Seq.:<| Seq (GovActionState Conway)
_gass -> forall a b. Either a b -> Bool
isRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Era era =>
Proposals era -> Either String (GovRelation TreeMaybe era)
toGovRelationTreeEither forall a b. (a -> b) -> a -> b
$ forall era.
Voter (EraCrypto era)
-> Vote
-> GovActionId (EraCrypto era)
-> Proposals era
-> Proposals era
proposalsAddVote Voter StandardCrypto
voter Vote
vote (forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId GovActionState Conway
gas) Proposals Conway
pfeProposals
              Seq (GovActionState Conway)
_ -> Bool
True
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Enacting exhaustive lineages reduces Proposals to their roots" forall a b. (a -> b) -> a -> b
$
        \( ProposalsForEnactment {Proposals Conway
pfeProposals :: Proposals Conway
pfeProposals :: forall era. ProposalsForEnactment era -> Proposals era
pfeProposals, Seq (GovActionState Conway)
pfeToEnact :: Seq (GovActionState Conway)
pfeToEnact :: forall era. ProposalsForEnactment era -> Seq (GovActionState era)
pfeToEnact, Set (GovActionId (EraCrypto Conway))
pfeToRemove :: forall era.
ProposalsForEnactment era -> Set (GovActionId (EraCrypto era))
pfeToRemove :: Set (GovActionId (EraCrypto Conway))
pfeToRemove, Set (GovActionId (EraCrypto Conway))
pfeToRetain :: forall era.
ProposalsForEnactment era -> Set (GovActionId (EraCrypto era))
pfeToRetain :: Set (GovActionId (EraCrypto Conway))
pfeToRetain} ::
            ProposalsForEnactment Conway
          ) -> do
            let (Proposals Conway
ps', Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
enacted, Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
removedDueToEnactment, Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
expiredRemoved) = forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsApplyEnactment Seq (GovActionState Conway)
pfeToEnact forall a. Set a
Set.empty Proposals Conway
pfeProposals
            Map (GovActionId StandardCrypto) (GovActionState Conway)
expiredRemoved forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` forall k a. Map k a -> Bool
Map.null
            Map (GovActionId StandardCrypto) (GovActionState Conway)
enacted forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId Seq (GovActionState Conway)
pfeToEnact
            forall k a. Map k a -> Set k
Map.keysSet Map (GovActionId StandardCrypto) (GovActionState Conway)
removedDueToEnactment forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Set (GovActionId (EraCrypto Conway))
pfeToRemove
            forall era. Proposals era -> Int
proposalsSize Proposals Conway
ps' forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Set a -> Int
Set.size Set (GovActionId (EraCrypto Conway))
pfeToRetain
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Enacting non-member nodes throws an AssertionFailure" forall a b. (a -> b) -> a -> b
$
        \(ProposalsNewActions Proposals Conway
ps [GovActionState Conway]
actions :: ProposalsNewActions Conway) ->
          (forall a. a -> IO a
evaluate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NFData a => a -> a
force) (forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsApplyEnactment (forall a. [a] -> Seq a
fromList [GovActionState Conway]
actions) forall a. Set a
Set.empty Proposals Conway
ps)
            forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \AssertionFailed {} -> Bool
True
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Expiring compliments of exhaustive lineages keeps proposals consistent" forall a b. (a -> b) -> a -> b
$
        \( ProposalsForEnactment {Proposals Conway
pfeProposals :: Proposals Conway
pfeProposals :: forall era. ProposalsForEnactment era -> Proposals era
pfeProposals, Seq (GovActionState Conway)
pfeToEnact :: Seq (GovActionState Conway)
pfeToEnact :: forall era. ProposalsForEnactment era -> Seq (GovActionState era)
pfeToEnact, Set (GovActionId (EraCrypto Conway))
pfeToRemove :: Set (GovActionId (EraCrypto Conway))
pfeToRemove :: forall era.
ProposalsForEnactment era -> Set (GovActionId (EraCrypto era))
pfeToRemove, Set (GovActionId (EraCrypto Conway))
pfeToRetain :: Set (GovActionId (EraCrypto Conway))
pfeToRetain :: forall era.
ProposalsForEnactment era -> Set (GovActionId (EraCrypto era))
pfeToRetain} ::
            ProposalsForEnactment Conway
          ) -> do
            let (Proposals Conway
ps', Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
enacted, Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
removedDueToEnactment, Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
expiredRemoved) =
                  forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsApplyEnactment forall a. Seq a
Seq.Empty Set (GovActionId (EraCrypto Conway))
pfeToRemove Proposals Conway
pfeProposals
            Map (GovActionId StandardCrypto) (GovActionState Conway)
enacted forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Monoid a => a
mempty
            Map (GovActionId StandardCrypto) (GovActionState Conway)
removedDueToEnactment forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Monoid a => a
mempty
            forall k a. Map k a -> Set k
Map.keysSet Map (GovActionId StandardCrypto) (GovActionState Conway)
expiredRemoved forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Set (GovActionId (EraCrypto Conway))
pfeToRemove
            Proposals Conway
ps' forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a b. (a, b) -> a
fst (forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveWithDescendants Set (GovActionId (EraCrypto Conway))
pfeToRemove Proposals Conway
pfeProposals)
            let enactMap :: Map (GovActionId StandardCrypto) (GovActionState Conway)
enactMap = forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId Seq (GovActionState Conway)
pfeToEnact
            let (Proposals Conway
emptyProposals, Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
enactedMap) = forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveWithDescendants (forall k a. Map k a -> Set k
Map.keysSet Map (GovActionId StandardCrypto) (GovActionState Conway)
enactMap) Proposals Conway
ps'
            forall era. Proposals era -> Int
proposalsSize Proposals Conway
emptyProposals forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Set a -> Int
Set.size Set (GovActionId (EraCrypto Conway))
pfeToRetain
            Map (GovActionId StandardCrypto) (GovActionState Conway)
enactedMap forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Map (GovActionId StandardCrypto) (GovActionState Conway)
enactMap
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Expiring non-member nodes throws an AssertionFailure" forall a b. (a -> b) -> a -> b
$
        \(ProposalsNewActions Proposals Conway
ps [GovActionState Conway]
actions :: ProposalsNewActions Conway) ->
          (forall a. a -> IO a
evaluate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NFData a => a -> a
force) (forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsApplyEnactment forall a. Seq a
Seq.Empty (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GovActionState Conway]
actions) Proposals Conway
ps)
            forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \AssertionFailed {} -> Bool
True
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Enacting and expiring conflicting proposals does not lead to removal due to enactment" forall a b. (a -> b) -> a -> b
$
        \( ProposalsForEnactment {Proposals Conway
pfeProposals :: Proposals Conway
pfeProposals :: forall era. ProposalsForEnactment era -> Proposals era
pfeProposals, Seq (GovActionState Conway)
pfeToEnact :: Seq (GovActionState Conway)
pfeToEnact :: forall era. ProposalsForEnactment era -> Seq (GovActionState era)
pfeToEnact, Set (GovActionId (EraCrypto Conway))
pfeToRemove :: Set (GovActionId (EraCrypto Conway))
pfeToRemove :: forall era.
ProposalsForEnactment era -> Set (GovActionId (EraCrypto era))
pfeToRemove, Set (GovActionId (EraCrypto Conway))
pfeToRetain :: Set (GovActionId (EraCrypto Conway))
pfeToRetain :: forall era.
ProposalsForEnactment era -> Set (GovActionId (EraCrypto era))
pfeToRetain} ::
            ProposalsForEnactment Conway
          ) -> do
            let (Proposals Conway
ps', Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
enacted, Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
enactedRemoved, Map (GovActionId (EraCrypto Conway)) (GovActionState Conway)
expiredRemoved) = forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsApplyEnactment Seq (GovActionState Conway)
pfeToEnact Set (GovActionId (EraCrypto Conway))
pfeToRemove Proposals Conway
pfeProposals
            forall k a. Map k a -> Set k
Map.keysSet Map (GovActionId StandardCrypto) (GovActionState Conway)
expiredRemoved forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Set (GovActionId (EraCrypto Conway))
pfeToRemove
            Map (GovActionId StandardCrypto) (GovActionState Conway)
enactedRemoved forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Monoid a => a
mempty
            Map (GovActionId StandardCrypto) (GovActionState Conway)
enacted forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId Seq (GovActionState Conway)
pfeToEnact
            forall era. Proposals era -> Int
proposalsSize Proposals Conway
ps' forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Set a -> Int
Set.size Set (GovActionId (EraCrypto Conway))
pfeToRetain