Skip to content

Commit

Permalink
Merge pull request #332 from input-output-hk/newhoggy/improved-validi…
Browse files Browse the repository at this point in the history
…ty-range-handling

Improved validity range handling
  • Loading branch information
newhoggy authored Oct 23, 2023
2 parents d11b423 + 69464d4 commit 807342e
Show file tree
Hide file tree
Showing 7 changed files with 278 additions and 189 deletions.
1 change: 1 addition & 0 deletions cardano-api/cardano-api.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -101,6 +101,7 @@ library internal
Cardano.Api.Keys.Praos
Cardano.Api.Keys.Read
Cardano.Api.Keys.Shelley
Cardano.Api.Ledger.Lens
Cardano.Api.LedgerEvent
Cardano.Api.LedgerState
Cardano.Api.Modes
Expand Down
17 changes: 5 additions & 12 deletions cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
Original file line number Diff line number Diff line change
Expand Up @@ -106,7 +106,6 @@ module Test.Gen.Cardano.Api.Typed
, genTxTotalCollateral
, genTxUpdateProposal
, genTxValidityLowerBound
, genTxValidityRange
, genTxValidityUpperBound
, genTxWithdrawals
, genUnsignedQuantity
Expand Down Expand Up @@ -548,15 +547,7 @@ genTxValidityUpperBound era =
(error "genTxValidityUpperBound: unexpected era support combination")
(pure . TxValidityNoUpperBound)
)
(\w -> TxValidityUpperBound w <$> genTtl)

genTxValidityRange
:: CardanoEra era
-> Gen (TxValidityLowerBound era, TxValidityUpperBound era)
genTxValidityRange era =
(,)
<$> genTxValidityLowerBound era
<*> genTxValidityUpperBound era
(\w -> TxValidityUpperBound w <$> Gen.maybe genTtl)

genTxMetadataInEra :: CardanoEra era -> Gen (TxMetadataInEra era)
genTxMetadataInEra =
Expand Down Expand Up @@ -647,7 +638,8 @@ genTxBodyContent era = do
txTotalCollateral <- genTxTotalCollateral era
txReturnCollateral <- genTxReturnCollateral era
txFee <- genTxFee era
txValidityRange <- genTxValidityRange era
txValidityLowerBound <- genTxValidityLowerBound era
txValidityUpperBound <- genTxValidityUpperBound era
txMetadata <- genTxMetadataInEra era
txAuxScripts <- genTxAuxScripts era
let txExtraKeyWits = TxExtraKeyWitnessesNone --TODO: Alonzo era: Generate witness key hashes
Expand All @@ -669,7 +661,8 @@ genTxBodyContent era = do
, Api.txTotalCollateral
, Api.txReturnCollateral
, Api.txFee
, Api.txValidityRange
, Api.txValidityLowerBound
, Api.txValidityUpperBound
, Api.txMetadata
, Api.txAuxScripts
, Api.txExtraKeyWits
Expand Down
1 change: 1 addition & 0 deletions cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs
Original file line number Diff line number Diff line change
Expand Up @@ -72,6 +72,7 @@ type ShelleyEraOnlyConstraints era =
, L.EraTx (ShelleyLedgerEra era)
, L.EraTxBody (ShelleyLedgerEra era)
, L.ExactEra L.ShelleyEra (ShelleyLedgerEra era)
, L.ExactEra L.ShelleyEra (ShelleyLedgerEra era)
, L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto
, L.ProtVerAtMost (ShelleyLedgerEra era) 2
, L.ProtVerAtMost (ShelleyLedgerEra era) 6
Expand Down
11 changes: 11 additions & 0 deletions cardano-api/internal/Cardano/Api/Eras/Case.hs
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,7 @@ module Cardano.Api.Eras.Case
-- Conversions
, shelleyToAllegraEraToByronToAllegraEra
, shelleyToAlonzoEraToShelleyToBabbageEra
, allegraEraOnwardsToByronAndAllegraOnwardsEra
, alonzoEraOnwardsToMaryEraOnwards
, babbageEraOnwardsToMaryEraOnwards
, babbageEraOnwardsToAlonzoEraOnwards
Expand Down Expand Up @@ -241,6 +242,16 @@ shelleyToAlonzoEraToShelleyToBabbageEra = \case
ShelleyToAlonzoEraMary -> ShelleyToBabbageEraMary
ShelleyToAlonzoEraAlonzo -> ShelleyToBabbageEraAlonzo

allegraEraOnwardsToByronAndAllegraOnwardsEra :: ()
=> AllegraEraOnwards era
-> ByronAndAllegraEraOnwards era
allegraEraOnwardsToByronAndAllegraOnwardsEra = \case
AllegraEraOnwardsAllegra -> ByronAndAllegraEraOnwardsAllegra
AllegraEraOnwardsMary -> ByronAndAllegraEraOnwardsMary
AllegraEraOnwardsAlonzo -> ByronAndAllegraEraOnwardsAlonzo
AllegraEraOnwardsBabbage -> ByronAndAllegraEraOnwardsBabbage
AllegraEraOnwardsConway -> ByronAndAllegraEraOnwardsConway

alonzoEraOnwardsToMaryEraOnwards :: ()
=> AlonzoEraOnwards era
-> MaryEraOnwards era
Expand Down
101 changes: 101 additions & 0 deletions cardano-api/internal/Cardano/Api/Ledger/Lens.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,101 @@
{-# LANGUAGE RankNTypes #-}

{- HLINT ignore "Eta reduce" -}

module Cardano.Api.Ledger.Lens
( strictMaybeL
, invalidBeforeL
, invalidHereAfterL
, invalidBeforeStrictL
, invalidHereAfterStrictL
, invalidBeforeTxBodyL
, invalidHereAfterTxBodyL
, ttlAsInvalidHereAfterTxBodyL
) where

import Cardano.Api.Eon.AllegraEraOnwards
import Cardano.Api.Eon.ShelleyBasedEra
import Cardano.Api.Eon.ShelleyEraOnly
import Cardano.Api.Eras.Case

import qualified Cardano.Ledger.Allegra.Core as L
import qualified Cardano.Ledger.Api as L
import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (..))

import Lens.Micro

strictMaybeL :: Lens' (StrictMaybe a) (Maybe a)
strictMaybeL = lens g s
where
g :: StrictMaybe a -> Maybe a
g SNothing = Nothing
g (SJust x) = Just x

s :: StrictMaybe a -> Maybe a -> StrictMaybe a
s _ = maybe SNothing SJust

invalidBeforeTxBodyL :: AllegraEraOnwards era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo)
invalidBeforeTxBodyL w = allegraEraOnwardsConstraints w $ L.vldtTxBodyL . invalidBeforeL

-- | Compatibility lens that provides a consistent interface over 'ttlTxBodyL' and
-- 'vldtTxBodyL . invalidHereAfterStrictL' across all shelley based eras.
--
-- The ledger uses 'ttlTxBodyL' in 'Shelley' only and from Allegra onwards uses 'vldtTxBodyL' instead.
--
-- The former is a 'SlotNo' with no limit represented as 'maxBound'.
--
-- The latter is a 'ValidityInterval' which is a pair of 'SlotNo's that represent the lower and upper
-- bounds.
--
-- The upper bound field is similar t 'ttlTxBodyL' except it is a 'StrictMaybe SlotNo' type where
-- no bounds is represented by 'SNothing'.
--
-- 'invalidHereAfterTxBodyL' lens over both with a 'Maybe SlotNo' type representation. Withing the
-- Shelley era, setting Nothing will set the ttl to 'maxBound' in the underlying ledger type.
invalidHereAfterTxBodyL :: ShelleyBasedEra era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo)
invalidHereAfterTxBodyL =
caseShelleyEraOnlyOrAllegraEraOnwards
ttlAsInvalidHereAfterTxBodyL
(const $ L.vldtTxBodyL . invalidHereAfterL)

-- | Compatibility lens over 'ttlTxBodyL' which represents 'maxBound' as Nothing and all other values as 'Just'.
ttlAsInvalidHereAfterTxBodyL :: ShelleyEraOnly era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo)
ttlAsInvalidHereAfterTxBodyL w = lens (g w) (s w)
where
g :: ShelleyEraOnly era -> L.TxBody (ShelleyLedgerEra era) -> Maybe SlotNo
g w' txBody =
shelleyEraOnlyConstraints w' $
let ttl = txBody ^. L.ttlTxBodyL in if ttl == maxBound then Nothing else Just ttl

s :: ShelleyEraOnly era -> L.TxBody (ShelleyLedgerEra era) -> Maybe SlotNo -> L.TxBody (ShelleyLedgerEra era)
s w' txBody mSlotNo =
shelleyEraOnlyConstraints w' $
case mSlotNo of
Nothing -> txBody & L.ttlTxBodyL .~ maxBound
Just ttl -> txBody & L.ttlTxBodyL .~ ttl

invalidBeforeL :: Lens' L.ValidityInterval (Maybe SlotNo)
invalidBeforeL = invalidBeforeStrictL . strictMaybeL

invalidHereAfterL :: Lens' L.ValidityInterval (Maybe SlotNo)
invalidHereAfterL = invalidHereAfterStrictL . strictMaybeL

-- | Lens to access the 'invalidBefore' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'.
invalidBeforeStrictL :: Lens' L.ValidityInterval (StrictMaybe SlotNo)
invalidBeforeStrictL = lens g s
where
g :: L.ValidityInterval -> StrictMaybe SlotNo
g (L.ValidityInterval a _) = a

s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval
s (L.ValidityInterval _ b) a = L.ValidityInterval a b

-- | Lens to access the 'invalidHereAfter' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'.
invalidHereAfterStrictL :: Lens' L.ValidityInterval (StrictMaybe SlotNo)
invalidHereAfterStrictL = lens g s
where
g :: L.ValidityInterval -> StrictMaybe SlotNo
g (L.ValidityInterval _ b) = b

s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval
s (L.ValidityInterval a _) b = L.ValidityInterval a b
Loading

0 comments on commit 807342e

Please sign in to comment.