{-# 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 ConwayEra
ps [GovActionState ConwayEra]
actions :: ProposalsNewActions ConwayEra) ->
          let ps' :: Proposals ConwayEra
ps' =
                forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl'
                  (\Proposals ConwayEra
p GovActionState ConwayEra
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 ConwayEra
action Proposals ConwayEra
p)
                  Proposals ConwayEra
ps
                  [GovActionState ConwayEra]
actions
              actionsMap :: Map GovActionId (GovActionState ConwayEra)
actionsMap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (\Map GovActionId (GovActionState ConwayEra)
accum GovActionState ConwayEra
gas -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall era. GovActionState era -> GovActionId
gasId GovActionState ConwayEra
gas) GovActionState ConwayEra
gas Map GovActionId (GovActionState ConwayEra)
accum) forall k a. Map k a
Map.empty [GovActionState ConwayEra]
actions
           in Map GovActionId (GovActionState ConwayEra)
actionsMap forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` (Map GovActionId (GovActionState ConwayEra)
actionsMap forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.intersection` forall era. Proposals era -> Map GovActionId (GovActionState era)
proposalsActionsMap Proposals ConwayEra
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 ConwayEra
ps :: Proposals ConwayEra) -> do
          let gais :: Set GovActionId
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
proposalsIds Proposals ConwayEra
ps
              ps' :: Proposals ConwayEra
ps' = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall era.
EraPParams era =>
Set GovActionId
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era))
proposalsRemoveWithDescendants Set GovActionId
gais Proposals ConwayEra
ps
          forall era. Proposals era -> Int
proposalsSize Proposals ConwayEra
ps' forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall era. Proposals era -> Int
proposalsSize Proposals ConwayEra
ps forall a. Num a => a -> a -> a
- forall a. Set a -> Int
Set.size Set GovActionId
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 ConwayEra
ps :: Proposals ConwayEra) -> do
          let gais :: Set GovActionId
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
proposalsIds Proposals ConwayEra
ps
              ps' :: Proposals ConwayEra
ps' = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall era.
EraPParams era =>
Set GovActionId
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era))
proposalsRemoveWithDescendants Set GovActionId
gais Proposals ConwayEra
ps
          forall era. Proposals era -> Int
proposalsSize Proposals ConwayEra
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 ConwayEra
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 ConwayEra
ps [GovActionState ConwayEra]
actions :: ProposalsNewActions ConwayEra) ->
          (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
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era))
proposalsRemoveWithDescendants (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall era. GovActionState era -> GovActionId
gasId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GovActionState ConwayEra]
actions) Proposals ConwayEra
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 ConwayEra
pfeProposals :: forall era. ProposalsForEnactment era -> Proposals era
pfeProposals :: Proposals ConwayEra
pfeProposals, Seq (GovActionState ConwayEra)
pfeToEnact :: forall era. ProposalsForEnactment era -> Seq (GovActionState era)
pfeToEnact :: Seq (GovActionState ConwayEra)
pfeToEnact} :: ProposalsForEnactment ConwayEra
          , Voter
voter :: Voter
          , Vote
vote :: Vote
          ) -> do
            case Seq (GovActionState ConwayEra)
pfeToEnact of
              GovActionState ConwayEra
gas Seq.:<| Seq (GovActionState ConwayEra)
_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 -> Vote -> GovActionId -> Proposals era -> Proposals era
proposalsAddVote Voter
voter Vote
vote (forall era. GovActionState era -> GovActionId
gasId GovActionState ConwayEra
gas) Proposals ConwayEra
pfeProposals
              Seq (GovActionState ConwayEra)
_ -> 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 ConwayEra
pfeProposals :: Proposals ConwayEra
pfeProposals :: forall era. ProposalsForEnactment era -> Proposals era
pfeProposals, Seq (GovActionState ConwayEra)
pfeToEnact :: Seq (GovActionState ConwayEra)
pfeToEnact :: forall era. ProposalsForEnactment era -> Seq (GovActionState era)
pfeToEnact, Set GovActionId
pfeToRemove :: forall era. ProposalsForEnactment era -> Set GovActionId
pfeToRemove :: Set GovActionId
pfeToRemove, Set GovActionId
pfeToRetain :: forall era. ProposalsForEnactment era -> Set GovActionId
pfeToRetain :: Set GovActionId
pfeToRetain} ::
            ProposalsForEnactment ConwayEra
          ) -> do
            let (Proposals ConwayEra
ps', Map GovActionId (GovActionState ConwayEra)
enacted, Map GovActionId (GovActionState ConwayEra)
removedDueToEnactment, Map GovActionId (GovActionState ConwayEra)
expiredRemoved) = forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set GovActionId
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era))
proposalsApplyEnactment Seq (GovActionState ConwayEra)
pfeToEnact forall a. Set a
Set.empty Proposals ConwayEra
pfeProposals
            Map GovActionId (GovActionState ConwayEra)
expiredRemoved forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` forall k a. Map k a -> Bool
Map.null
            Map GovActionId (GovActionState ConwayEra)
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
gasId Seq (GovActionState ConwayEra)
pfeToEnact
            forall k a. Map k a -> Set k
Map.keysSet Map GovActionId (GovActionState ConwayEra)
removedDueToEnactment forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Set GovActionId
pfeToRemove
            forall era. Proposals era -> Int
proposalsSize Proposals ConwayEra
ps' forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Set a -> Int
Set.size Set GovActionId
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 ConwayEra
ps [GovActionState ConwayEra]
actions :: ProposalsNewActions ConwayEra) ->
          (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
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era))
proposalsApplyEnactment (forall a. [a] -> Seq a
fromList [GovActionState ConwayEra]
actions) forall a. Set a
Set.empty Proposals ConwayEra
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 ConwayEra
pfeProposals :: Proposals ConwayEra
pfeProposals :: forall era. ProposalsForEnactment era -> Proposals era
pfeProposals, Seq (GovActionState ConwayEra)
pfeToEnact :: Seq (GovActionState ConwayEra)
pfeToEnact :: forall era. ProposalsForEnactment era -> Seq (GovActionState era)
pfeToEnact, Set GovActionId
pfeToRemove :: Set GovActionId
pfeToRemove :: forall era. ProposalsForEnactment era -> Set GovActionId
pfeToRemove, Set GovActionId
pfeToRetain :: Set GovActionId
pfeToRetain :: forall era. ProposalsForEnactment era -> Set GovActionId
pfeToRetain} ::
            ProposalsForEnactment ConwayEra
          ) -> do
            let (Proposals ConwayEra
ps', Map GovActionId (GovActionState ConwayEra)
enacted, Map GovActionId (GovActionState ConwayEra)
removedDueToEnactment, Map GovActionId (GovActionState ConwayEra)
expiredRemoved) =
                  forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set GovActionId
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era))
proposalsApplyEnactment forall a. Seq a
Seq.Empty Set GovActionId
pfeToRemove Proposals ConwayEra
pfeProposals
            Map GovActionId (GovActionState ConwayEra)
enacted forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Monoid a => a
mempty
            Map GovActionId (GovActionState ConwayEra)
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 (GovActionState ConwayEra)
expiredRemoved forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Set GovActionId
pfeToRemove
            Proposals ConwayEra
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
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era))
proposalsRemoveWithDescendants Set GovActionId
pfeToRemove Proposals ConwayEra
pfeProposals)
            let enactMap :: Map GovActionId (GovActionState ConwayEra)
enactMap = forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems forall era. GovActionState era -> GovActionId
gasId Seq (GovActionState ConwayEra)
pfeToEnact
            let (Proposals ConwayEra
emptyProposals, Map GovActionId (GovActionState ConwayEra)
enactedMap) = forall era.
EraPParams era =>
Set GovActionId
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era))
proposalsRemoveWithDescendants (forall k a. Map k a -> Set k
Map.keysSet Map GovActionId (GovActionState ConwayEra)
enactMap) Proposals ConwayEra
ps'
            forall era. Proposals era -> Int
proposalsSize Proposals ConwayEra
emptyProposals forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Set a -> Int
Set.size Set GovActionId
pfeToRetain
            Map GovActionId (GovActionState ConwayEra)
enactedMap forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Map GovActionId (GovActionState ConwayEra)
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 ConwayEra
ps [GovActionState ConwayEra]
actions :: ProposalsNewActions ConwayEra) ->
          (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
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era),
    Map GovActionId (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
gasId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GovActionState ConwayEra]
actions) Proposals ConwayEra
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 ConwayEra
pfeProposals :: Proposals ConwayEra
pfeProposals :: forall era. ProposalsForEnactment era -> Proposals era
pfeProposals, Seq (GovActionState ConwayEra)
pfeToEnact :: Seq (GovActionState ConwayEra)
pfeToEnact :: forall era. ProposalsForEnactment era -> Seq (GovActionState era)
pfeToEnact, Set GovActionId
pfeToRemove :: Set GovActionId
pfeToRemove :: forall era. ProposalsForEnactment era -> Set GovActionId
pfeToRemove, Set GovActionId
pfeToRetain :: Set GovActionId
pfeToRetain :: forall era. ProposalsForEnactment era -> Set GovActionId
pfeToRetain} ::
            ProposalsForEnactment ConwayEra
          ) -> do
            let (Proposals ConwayEra
ps', Map GovActionId (GovActionState ConwayEra)
enacted, Map GovActionId (GovActionState ConwayEra)
enactedRemoved, Map GovActionId (GovActionState ConwayEra)
expiredRemoved) = forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set GovActionId
-> Proposals era
-> (Proposals era, Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era),
    Map GovActionId (GovActionState era))
proposalsApplyEnactment Seq (GovActionState ConwayEra)
pfeToEnact Set GovActionId
pfeToRemove Proposals ConwayEra
pfeProposals
            forall k a. Map k a -> Set k
Map.keysSet Map GovActionId (GovActionState ConwayEra)
expiredRemoved forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Set GovActionId
pfeToRemove
            Map GovActionId (GovActionState ConwayEra)
enactedRemoved forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Monoid a => a
mempty
            Map GovActionId (GovActionState ConwayEra)
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
gasId Seq (GovActionState ConwayEra)
pfeToEnact
            forall era. Proposals era -> Int
proposalsSize Proposals ConwayEra
ps' forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Set a -> Int
Set.size Set GovActionId
pfeToRetain