WIP FIX flaky test

There is a problem with the way we test validity bounds mutations. Most
of the arbitrarily generated values will make the validator fail but
there are no reason to not generate valid transaction with what we had.

To fix that, we distinguish between 3 situations:

1. The lower bound is infinite
2. The upper bound is infinite
3. The upper bound is too high given the contestation deadline

Note: case 3. is implemented but the code is not that pretty.
We should improve this part a bit and, myabe, amend this commit with the
change and remove this note from the commit message.

hydra-cardano-api/src/Hydra/Cardano/Api/ValidityInterval.hs

@@ -22,6 +22,18 @@ toLedgerValidityInterval (lowerBound, upperBound) =
           TxValidityNoUpperBound _ -> SNothing
           TxValidityUpperBound _ s -> SJust s
     }
+fromLedgerValidityInterval ::
+  Ledger.ValidityInterval ->
+  (TxValidityLowerBound Era, TxValidityUpperBound Era)
+fromLedgerValidityInterval validityInterval =
+  let Ledger.ValidityInterval{Ledger.invalidBefore = invalidBefore, Ledger.invalidHereafter = invalidHereAfter} = validityInterval
+      lowerBound = case invalidBefore of
+        SNothing -> TxValidityNoLowerBound
+        SJust s -> TxValidityLowerBound ValidityLowerBoundInBabbageEra s
+      upperBound = case invalidHereAfter of
+        SNothing -> TxValidityNoUpperBound ValidityNoUpperBoundInBabbageEra
+        SJust s -> TxValidityUpperBound ValidityUpperBoundInBabbageEra s
+   in (lowerBound, upperBound)
 
 instance Arbitrary (TxValidityLowerBound Era) where
   arbitrary =

hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs

@@ -18,12 +18,12 @@ import Hydra.ContestationPeriod (fromChain)
 import qualified Hydra.Contract.HeadState as Head
 import Hydra.Contract.HeadTokens (headPolicyId)
 import Hydra.Crypto (HydraKey, MultiSignature, aggregate, sign, toPlutusSignatures)
-import Hydra.Data.ContestationPeriod (posixFromUTCTime)
+import Hydra.Data.ContestationPeriod (addContestationPeriod, posixFromUTCTime)
 import qualified Hydra.Data.ContestationPeriod as OnChain
 import qualified Hydra.Data.Party as OnChain
 import Hydra.Ledger (hashUTxO)
 import Hydra.Ledger.Cardano (genOneUTxOFor, genVerificationKey)
-import Hydra.Ledger.Cardano.Evaluate (genValidityBoundsFromContestationPeriod)
+import Hydra.Ledger.Cardano.Evaluate (genPointInTime, genValidityBoundsFromContestationPeriod)
 import Hydra.Party (Party, deriveParty, partyToChain)
 import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
 import Plutus.Orphans ()
@@ -196,11 +196,21 @@ data CloseMutation
   | MutateCloseUTxOHash
   | -- | Changing the validity interval to not be bounded by contestation
     -- period. See spec: 5.5, rule 5
+    -- See spec: 5.5. rule 5 -> upperBound - lowerBound <= contestationPeriod
     MutateValidityInterval
   | -- | Changing the deadline without chanigng the upper bound ensures they are
     -- checked to correspond. See spec: 5.5, rule 4
-    MutateCloseContestationDeadline
-  | MutateHeadId
+    -- Spec translation:
+    -- lowerBound -> rmin
+    -- upperbound -> rmax
+    -- contestationPeriod -> T
+    -- contesationDeadline -> Tfinal
+    InfiniteLowerBound
+  | InfiniteUpperBound
+  | -- | rule 5.5#4 -> contestationDeadline = upperBound + contestationPeriod
+    MutateContestationDeadline
+  | -- | rule 5.5#4 -> contestationDeadline = upperBound + contestationPeriod
+    MutateHeadId
   deriving (Generic, Show, Enum, Bounded)
 
 genCloseMutation :: (Tx, UTxO) -> Gen SomeMutation
@@ -227,13 +237,22 @@ genCloseMutation (tx, _utxo) =
         newSigner <- verificationKeyHash <$> genVerificationKey
         pure $ ChangeRequiredSigners [newSigner]
     , SomeMutation Nothing MutateCloseUTxOHash . ChangeOutput 0 <$> mutateCloseUTxOHash
-    , SomeMutation (Just "incorrect closed contestation deadline") MutateCloseContestationDeadline <$> do
+    , SomeMutation (Just "incorrect closed contestation deadline") MutateContestationDeadline <$> do
         mutatedDeadline <- genMutatedDeadline
         pure $ ChangeOutput 0 $ changeHeadOutputDatum (replaceContestationDeadline mutatedDeadline) headTxOut
-    , SomeMutation Nothing MutateValidityInterval . ChangeValidityInterval <$> do
-        lb <- arbitrary
-        ub <- arbitrary `suchThat` (/= TxValidityUpperBound brokenSlotNo)
-        pure (lb, ub)
+    , SomeMutation (Just "infinite lower bound") InfiniteLowerBound . ChangeValidityLowerBound <$> do
+        pure TxValidityNoLowerBound
+    , SomeMutation (Just "infinite upper bound") InfiniteUpperBound . ChangeValidityUpperBound <$> do
+        pure TxValidityNoUpperBound
+    , SomeMutation (Just "hasBoundedValidity check failed") MutateValidityInterval <$> do
+        (lbSlotNo, lbUTCTime) <- genPointInTime
+        (ubSlotNo, ubUTCTime) <- genPointInTime `suchThat` ((> (addContestationPeriod (posixFromUTCTime lbUTCTime) healthyContestationPeriod)) . posixFromUTCTime . snd)
+        let adjustedContestationDeadline = addContestationPeriod (posixFromUTCTime ubUTCTime) healthyContestationPeriod
+        pure $
+          Changes
+            [ ChangeValidityInterval (TxValidityLowerBound lbSlotNo, TxValidityUpperBound ubSlotNo)
+            , ChangeOutput 0 $ changeHeadOutputDatum (replaceContestationDeadline adjustedContestationDeadline) headTxOut
+            ]
     , SomeMutation Nothing MutateHeadId <$> do
         otherHeadId <- headPolicyId <$> arbitrary `suchThat` (/= Fixture.testSeedInput)
         pure $
@@ -275,8 +294,8 @@ genMutatedDeadline = do
     , valuesAroundDeadline
     ]
  where
-  valuesAroundZero = arbitrary `suchThat` (/= dl)
+  valuesAroundZero = arbitrary `suchThat` (/= deadline)
 
-  valuesAroundDeadline = arbitrary `suchThat` (/= 0) <&> (+ dl)
+  valuesAroundDeadline = arbitrary `suchThat` (/= 0) <&> (+ deadline)
 
-  dl = posixFromUTCTime healthyContestationDeadline
+  deadline = posixFromUTCTime healthyContestationDeadline

hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs

@@ -278,6 +278,8 @@ data Mutation
     ChangeRequiredSigners [Hash PaymentKey]
   | -- | Change the validity interval of the transaction.
     ChangeValidityInterval (TxValidityLowerBound, TxValidityUpperBound)
+  | ChangeValidityLowerBound TxValidityLowerBound
+  | ChangeValidityUpperBound TxValidityUpperBound
   | -- | Applies several mutations as a single atomic 'Mutation'.
     -- This is useful to enable specific mutations that require consistent
     -- change of more than one thing in the transaction and/or UTxO set, for
@@ -385,17 +387,30 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of
       ledgerBody
         { Ledger.reqSignerHashes = Set.fromList (toLedgerKeyHash <$> newSigners)
         }
-  ChangeValidityInterval (lb, up) ->
+  ChangeValidityInterval (lowerBound, upperBound) ->
+    changeValidityInterval (Just lowerBound) (Just upperBound)
+  ChangeValidityLowerBound bound ->
+    changeValidityInterval (Just bound) Nothing
+  ChangeValidityUpperBound bound ->
+    changeValidityInterval Nothing (Just bound)
+  Changes mutations ->
+    foldr applyMutation (tx, utxo) mutations
+ where
+  changeValidityInterval lowerBound' upperBound' =
     (Tx body' wits, utxo)
    where
     ShelleyTxBody ledgerBody scripts scriptData mAuxData scriptValidity = body
     body' = ShelleyTxBody ledgerBody' scripts scriptData mAuxData scriptValidity
     ledgerBody' =
       ledgerBody
-        { Ledger.txvldt = toLedgerValidityInterval (lb, up)
+        { Ledger.txvldt =
+            toLedgerValidityInterval
+              ( fromMaybe lowerBound lowerBound'
+              , fromMaybe upperBound upperBound'
+              )
         }
-  Changes mutations ->
-    foldr applyMutation (tx, utxo) mutations
+    (lowerBound, upperBound) = fromLedgerValidityInterval ledgerValidityInterval
+    ledgerValidityInterval = Ledger.txvldt ledgerBody
 
 --
 -- Generators