module Test.QuickCheck.ContractModel.ThreatModel.Cardano.Api where

import Cardano.Api
import Cardano.Api.Byron
import Cardano.Api.Shelley
import Cardano.Ledger.Alonzo.Tx qualified as Ledger (Data, hashData, indexOf)
import Cardano.Ledger.Alonzo.TxWitness qualified as Ledger
import Cardano.Ledger.Babbage.TxBody qualified as Ledger
import Cardano.Ledger.Crypto (StandardCrypto)
import Cardano.Ledger.Keys (coerceKeyRole, hashKey)
import Cardano.Ledger.Shelley.TxBody (Wdrl (..), WitVKey (..))
import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))
import Cardano.Ledger.TxIn (txid)
import Cardano.Slotting.Slot (EpochSize (EpochSize))
import Cardano.Slotting.Time (SlotLength, mkSlotLength)
import Ouroboros.Consensus.Cardano.Block (CardanoEras)
import Ouroboros.Consensus.HardFork.History
import Ouroboros.Consensus.Util.Counting (NonEmpty (NonEmptyOne))
import PlutusTx (ToData, toData)
import Cardano.Ledger.Alonzo.Scripts qualified as Ledger

import Data.Either
import Data.Map qualified as Map
import Data.Maybe.Strict
import Data.Sequence.Strict qualified as Seq
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word

import Test.QuickCheck.ContractModel.Internal.Common

addressOfTxOut :: TxOut ctx Era -> AddressAny
addressOfTxOut :: TxOut ctx Era -> AddressAny
addressOfTxOut (TxOut (AddressInEra ShelleyAddressInEra{}  Address addrtype
addr) TxOutValue Era
_ TxOutDatum ctx Era
_ ReferenceScript Era
_) = Address ShelleyAddr -> AddressAny
AddressShelley Address addrtype
Address ShelleyAddr
addr
addressOfTxOut (TxOut (AddressInEra ByronAddressInAnyEra{} Address addrtype
addr) TxOutValue Era
_ TxOutDatum ctx Era
_ ReferenceScript Era
_) = Address ByronAddr -> AddressAny
AddressByron   Address addrtype
Address ByronAddr
addr

valueOfTxOut :: TxOut ctx Era -> Value
valueOfTxOut :: TxOut ctx Era -> Value
valueOfTxOut (TxOut AddressInEra Era
_ (TxOutAdaOnly OnlyAdaSupportedInEra Era
_ Lovelace
v) TxOutDatum ctx Era
_ ReferenceScript Era
_) = Lovelace -> Value
lovelaceToValue Lovelace
v
valueOfTxOut (TxOut AddressInEra Era
_ (TxOutValue MultiAssetSupportedInEra Era
_ Value
v) TxOutDatum ctx Era
_ ReferenceScript Era
_)   = Value
v

-- | Get the datum from a transaction output.
datumOfTxOut :: TxOut ctx Era -> TxOutDatum ctx Era
datumOfTxOut :: TxOut ctx Era -> TxOutDatum ctx Era
datumOfTxOut (TxOut AddressInEra Era
_ TxOutValue Era
_ TxOutDatum ctx Era
datum ReferenceScript Era
_) = TxOutDatum ctx Era
datum

redeemerOfTxIn :: Tx Era -> TxIn -> Maybe ScriptData
redeemerOfTxIn :: Tx Era -> TxIn -> Maybe ScriptData
redeemerOfTxIn Tx Era
tx TxIn
txIn = Maybe ScriptData
redeemer
  where
    Tx (ShelleyTxBody ShelleyBasedEra Era
_ Ledger.TxBody{Ledger.inputs=inputs} [Script (ShelleyLedgerEra Era)]
_ TxBodyScriptData Era
scriptData Maybe (AuxiliaryData (ShelleyLedgerEra Era))
_ TxScriptValidity Era
_) [KeyWitness Era]
_ = Tx Era
tx

    redeemer :: Maybe ScriptData
redeemer = case TxBodyScriptData Era
scriptData of
      TxBodyScriptData Era
TxBodyNoScriptData -> Maybe ScriptData
forall a. Maybe a
Nothing
      TxBodyScriptData ScriptDataSupportedInEra Era
_ TxDats (ShelleyLedgerEra Era)
_ (Ledger.Redeemers rdmrs) ->
        Data StandardBabbage -> ScriptData
forall ledgerera. Data ledgerera -> ScriptData
fromAlonzoData (Data StandardBabbage -> ScriptData)
-> ((Data StandardBabbage, ExUnits) -> Data StandardBabbage)
-> (Data StandardBabbage, ExUnits)
-> ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Data StandardBabbage, ExUnits) -> Data StandardBabbage
forall a b. (a, b) -> a
fst ((Data StandardBabbage, ExUnits) -> ScriptData)
-> Maybe (Data StandardBabbage, ExUnits) -> Maybe ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RdmrPtr
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Maybe (Data StandardBabbage, ExUnits)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Tag -> Word64 -> RdmrPtr
Ledger.RdmrPtr Tag
Ledger.Spend Word64
idx) Map RdmrPtr (Data StandardBabbage, ExUnits)
rdmrs

    idx :: Word64
idx = case TxIn StandardCrypto
-> Set (TxIn StandardCrypto) -> StrictMaybe Word64
forall elem container.
Indexable elem container =>
elem -> container -> StrictMaybe Word64
Ledger.indexOf (TxIn -> TxIn StandardCrypto
toShelleyTxIn TxIn
txIn) Set (TxIn StandardCrypto)
Set (TxIn (Crypto StandardBabbage))
inputs of
      SJust Word64
idx -> Word64
idx
      StrictMaybe Word64
_         -> [Char] -> Word64
forall a. HasCallStack => [Char] -> a
error [Char]
"The impossible happened!"

paymentCredentialToAddressAny :: PaymentCredential -> AddressAny
paymentCredentialToAddressAny :: PaymentCredential -> AddressAny
paymentCredentialToAddressAny PaymentCredential
t =
  Address ShelleyAddr -> AddressAny
AddressShelley (Address ShelleyAddr -> AddressAny)
-> Address ShelleyAddr -> AddressAny
forall a b. (a -> b) -> a -> b
$ NetworkId
-> PaymentCredential
-> StakeAddressReference
-> Address ShelleyAddr
makeShelleyAddress (NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId) -> NetworkMagic -> NetworkId
forall a b. (a -> b) -> a -> b
$ Word32 -> NetworkMagic
NetworkMagic Word32
1) PaymentCredential
t StakeAddressReference
NoStakeAddress

-- | Construct a script address.
scriptAddressAny :: ScriptHash -> AddressAny
scriptAddressAny :: ScriptHash -> AddressAny
scriptAddressAny = PaymentCredential -> AddressAny
paymentCredentialToAddressAny (PaymentCredential -> AddressAny)
-> (ScriptHash -> PaymentCredential) -> ScriptHash -> AddressAny
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> PaymentCredential
PaymentCredentialByScript

-- | Construct a public key address.
keyAddressAny :: Hash PaymentKey -> AddressAny
keyAddressAny :: Hash PaymentKey -> AddressAny
keyAddressAny = PaymentCredential -> AddressAny
paymentCredentialToAddressAny (PaymentCredential -> AddressAny)
-> (Hash PaymentKey -> PaymentCredential)
-> Hash PaymentKey
-> AddressAny
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash PaymentKey -> PaymentCredential
PaymentCredentialByKey

-- | Check if an address is a public key address.
isKeyAddressAny :: AddressAny -> Bool
isKeyAddressAny :: AddressAny -> Bool
isKeyAddressAny = AddressInEra Era -> Bool
forall era. AddressInEra era -> Bool
isKeyAddress (AddressInEra Era -> Bool)
-> (AddressAny -> AddressInEra Era) -> AddressAny -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsShelleyBasedEra Era => AddressAny -> AddressInEra Era
forall era. IsShelleyBasedEra era => AddressAny -> AddressInEra era
anyAddressInShelleyBasedEra @Era

recomputeScriptData :: Maybe Word64 -- Index to remove
                    -> (Word64 -> Word64)
                    -> TxBodyScriptData Era
                    -> TxBodyScriptData Era
recomputeScriptData :: Maybe Word64
-> (Word64 -> Word64)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
recomputeScriptData Maybe Word64
_ Word64 -> Word64
_ TxBodyScriptData Era
TxBodyNoScriptData = TxBodyScriptData Era
forall era. TxBodyScriptData era
TxBodyNoScriptData
recomputeScriptData Maybe Word64
i Word64 -> Word64
f (TxBodyScriptData ScriptDataSupportedInEra Era
era TxDats (ShelleyLedgerEra Era)
dats (Ledger.Redeemers rdmrs)) =
  ScriptDataSupportedInEra Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
ScriptDataSupportedInEra era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData ScriptDataSupportedInEra Era
era TxDats (ShelleyLedgerEra Era)
dats
    (Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall era.
Era era =>
Map RdmrPtr (Data era, ExUnits) -> Redeemers era
Ledger.Redeemers (Map RdmrPtr (Data StandardBabbage, ExUnits)
 -> Redeemers StandardBabbage)
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall a b. (a -> b) -> a -> b
$ (RdmrPtr -> RdmrPtr)
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys RdmrPtr -> RdmrPtr
updatePtr (Map RdmrPtr (Data StandardBabbage, ExUnits)
 -> Map RdmrPtr (Data StandardBabbage, ExUnits))
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
forall a b. (a -> b) -> a -> b
$ (RdmrPtr -> (Data StandardBabbage, ExUnits) -> Bool)
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey RdmrPtr -> (Data StandardBabbage, ExUnits) -> Bool
idxFilter Map RdmrPtr (Data StandardBabbage, ExUnits)
rdmrs)
  where updatePtr :: RdmrPtr -> RdmrPtr
updatePtr (Ledger.RdmrPtr Tag
tag Word64
idx) = Tag -> Word64 -> RdmrPtr
Ledger.RdmrPtr Tag
tag (Word64 -> Word64
f Word64
idx)
        idxFilter :: RdmrPtr -> (Data StandardBabbage, ExUnits) -> Bool
idxFilter (Ledger.RdmrPtr Tag
_ Word64
idx) (Data StandardBabbage, ExUnits)
_ = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
idx Maybe Word64 -> Maybe Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Word64
i

emptyTxBodyScriptData :: TxBodyScriptData Era
emptyTxBodyScriptData :: TxBodyScriptData Era
emptyTxBodyScriptData = ScriptDataSupportedInEra Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
ScriptDataSupportedInEra era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData ScriptDataSupportedInEra Era
ScriptDataInBabbageEra (Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage
forall era.
Typeable era =>
Map (DataHash (Crypto era)) (Data era) -> TxDats era
Ledger.TxDats Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
forall a. Monoid a => a
mempty) (Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall era.
Era era =>
Map RdmrPtr (Data era, ExUnits) -> Redeemers era
Ledger.Redeemers Map RdmrPtr (Data StandardBabbage, ExUnits)
forall a. Monoid a => a
mempty)

addScriptData :: Word64
              -> Ledger.Data (ShelleyLedgerEra Era)
              -> (Ledger.Data (ShelleyLedgerEra Era), Ledger.ExUnits)
              -> TxBodyScriptData Era
              -> TxBodyScriptData Era
addScriptData :: Word64
-> Data (ShelleyLedgerEra Era)
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
addScriptData Word64
ix Data (ShelleyLedgerEra Era)
dat (Data (ShelleyLedgerEra Era), ExUnits)
rdmr TxBodyScriptData Era
TxBodyNoScriptData = Word64
-> Data (ShelleyLedgerEra Era)
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
addScriptData Word64
ix Data (ShelleyLedgerEra Era)
dat (Data (ShelleyLedgerEra Era), ExUnits)
rdmr TxBodyScriptData Era
emptyTxBodyScriptData
addScriptData Word64
ix Data (ShelleyLedgerEra Era)
dat (Data (ShelleyLedgerEra Era), ExUnits)
rdmr (TxBodyScriptData ScriptDataSupportedInEra Era
era (Ledger.TxDats dats) (Ledger.Redeemers rdmrs)) =
  ScriptDataSupportedInEra Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
ScriptDataSupportedInEra era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData ScriptDataSupportedInEra Era
era (Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage
forall era.
Typeable era =>
Map (DataHash (Crypto era)) (Data era) -> TxDats era
Ledger.TxDats (Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
 -> TxDats StandardBabbage)
-> Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage
forall a b. (a -> b) -> a -> b
$ DataHash StandardCrypto
-> Data StandardBabbage
-> Map (DataHash StandardCrypto) (Data StandardBabbage)
-> Map (DataHash StandardCrypto) (Data StandardBabbage)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Data StandardBabbage -> DataHash (Crypto StandardBabbage)
forall era. Era era => Data era -> DataHash (Crypto era)
Ledger.hashData Data (ShelleyLedgerEra Era)
Data StandardBabbage
dat) Data (ShelleyLedgerEra Era)
Data StandardBabbage
dat Map (DataHash StandardCrypto) (Data StandardBabbage)
Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
dats)
                       (Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall era.
Era era =>
Map RdmrPtr (Data era, ExUnits) -> Redeemers era
Ledger.Redeemers (Map RdmrPtr (Data StandardBabbage, ExUnits)
 -> Redeemers StandardBabbage)
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall a b. (a -> b) -> a -> b
$ RdmrPtr
-> (Data StandardBabbage, ExUnits)
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
-> Map RdmrPtr (Data StandardBabbage, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Tag -> Word64 -> RdmrPtr
Ledger.RdmrPtr Tag
Ledger.Spend Word64
ix) (Data (ShelleyLedgerEra Era), ExUnits)
(Data StandardBabbage, ExUnits)
rdmr Map RdmrPtr (Data StandardBabbage, ExUnits)
rdmrs)

addDatum :: Ledger.Data (ShelleyLedgerEra Era)
         -> TxBodyScriptData Era
         -> TxBodyScriptData Era
addDatum :: Data (ShelleyLedgerEra Era)
-> TxBodyScriptData Era -> TxBodyScriptData Era
addDatum Data (ShelleyLedgerEra Era)
dat TxBodyScriptData Era
TxBodyNoScriptData = Data (ShelleyLedgerEra Era)
-> TxBodyScriptData Era -> TxBodyScriptData Era
addDatum Data (ShelleyLedgerEra Era)
dat TxBodyScriptData Era
emptyTxBodyScriptData
addDatum Data (ShelleyLedgerEra Era)
dat (TxBodyScriptData ScriptDataSupportedInEra Era
era (Ledger.TxDats dats) Redeemers (ShelleyLedgerEra Era)
rdmrs) =
  ScriptDataSupportedInEra Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
ScriptDataSupportedInEra era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData ScriptDataSupportedInEra Era
era (Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage
forall era.
Typeable era =>
Map (DataHash (Crypto era)) (Data era) -> TxDats era
Ledger.TxDats (Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
 -> TxDats StandardBabbage)
-> Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage
forall a b. (a -> b) -> a -> b
$ DataHash StandardCrypto
-> Data StandardBabbage
-> Map (DataHash StandardCrypto) (Data StandardBabbage)
-> Map (DataHash StandardCrypto) (Data StandardBabbage)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Data StandardBabbage -> DataHash (Crypto StandardBabbage)
forall era. Era era => Data era -> DataHash (Crypto era)
Ledger.hashData Data (ShelleyLedgerEra Era)
Data StandardBabbage
dat) Data (ShelleyLedgerEra Era)
Data StandardBabbage
dat Map (DataHash StandardCrypto) (Data StandardBabbage)
Map (DataHash (Crypto StandardBabbage)) (Data StandardBabbage)
dats)
                       Redeemers (ShelleyLedgerEra Era)
rdmrs

toCtxUTxODatum :: TxOutDatum CtxTx Era -> TxOutDatum CtxUTxO Era
toCtxUTxODatum :: TxOutDatum CtxTx Era -> TxOutDatum CtxUTxO Era
toCtxUTxODatum TxOutDatum CtxTx Era
d = case TxOutDatum CtxTx Era
d of
  TxOutDatum CtxTx Era
TxOutDatumNone        -> TxOutDatum CtxUTxO Era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone
  TxOutDatumHash ScriptDataSupportedInEra Era
s Hash ScriptData
h    -> ScriptDataSupportedInEra Era
-> Hash ScriptData -> TxOutDatum CtxUTxO Era
forall era ctx.
ScriptDataSupportedInEra era
-> Hash ScriptData -> TxOutDatum ctx era
TxOutDatumHash ScriptDataSupportedInEra Era
s Hash ScriptData
h
  TxOutDatumInTx ScriptDataSupportedInEra Era
s ScriptData
d    -> ScriptDataSupportedInEra Era
-> Hash ScriptData -> TxOutDatum CtxUTxO Era
forall era ctx.
ScriptDataSupportedInEra era
-> Hash ScriptData -> TxOutDatum ctx era
TxOutDatumHash ScriptDataSupportedInEra Era
s (ScriptData -> Hash ScriptData
hashScriptData ScriptData
d)
  TxOutDatumInline ReferenceTxInsScriptsInlineDatumsSupportedInEra Era
s ScriptData
sd -> ReferenceTxInsScriptsInlineDatumsSupportedInEra Era
-> ScriptData -> TxOutDatum CtxUTxO Era
forall era ctx.
ReferenceTxInsScriptsInlineDatumsSupportedInEra era
-> ScriptData -> TxOutDatum ctx era
TxOutDatumInline ReferenceTxInsScriptsInlineDatumsSupportedInEra Era
s ScriptData
sd

-- | Convert ScriptData to a `Test.QuickCheck.ContractModel.ThreatModel.Datum`.
txOutDatum :: ScriptData -> TxOutDatum CtxTx Era
txOutDatum :: ScriptData -> TxOutDatum CtxTx Era
txOutDatum ScriptData
d = ScriptDataSupportedInEra Era -> ScriptData -> TxOutDatum CtxTx Era
forall era.
ScriptDataSupportedInEra era -> ScriptData -> TxOutDatum CtxTx era
TxOutDatumInTx ScriptDataSupportedInEra Era
ScriptDataInBabbageEra ScriptData
d

-- | Convert a Haskell value to ScriptData for use as a
-- `Test.QuickCheck.ContractModel.ThreatModel.Redeemer` or convert to a
-- `Test.QuickCheck.ContractModel.ThreatModel.Datum` with `txOutDatum`.
toScriptData :: ToData a => a -> ScriptData
toScriptData :: a -> ScriptData
toScriptData = Data -> ScriptData
fromPlutusData (Data -> ScriptData) -> (a -> Data) -> a -> ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Data
forall a. ToData a => a -> Data
toData

-- | Used for new inputs.
dummyTxId :: TxId
dummyTxId :: TxId
dummyTxId =
  TxId StandardCrypto -> TxId
fromShelleyTxId
  (TxId StandardCrypto -> TxId) -> TxId StandardCrypto -> TxId
forall a b. (a -> b) -> a -> b
$ forall c.
(HashAlgorithm (HASH c),
 HashAnnotated
   (TxBody (ShelleyLedgerEra Era)) EraIndependentTxBody c) =>
TxBody (ShelleyLedgerEra Era) -> TxId c
forall era c.
(HashAlgorithm (HASH c),
 HashAnnotated (TxBody era) EraIndependentTxBody c) =>
TxBody era -> TxId c
txid @LedgerEra
  (TxBody (ShelleyLedgerEra Era) -> TxId StandardCrypto)
-> TxBody (ShelleyLedgerEra Era) -> TxId StandardCrypto
forall a b. (a -> b) -> a -> b
$ Set (TxIn (Crypto (ShelleyLedgerEra Era)))
-> Set (TxIn (Crypto (ShelleyLedgerEra Era)))
-> Set (TxIn (Crypto (ShelleyLedgerEra Era)))
-> StrictSeq (Sized (TxOut (ShelleyLedgerEra Era)))
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
-> StrictMaybe Coin
-> StrictSeq (DCert (Crypto (ShelleyLedgerEra Era)))
-> Wdrl (Crypto (ShelleyLedgerEra Era))
-> Coin
-> ValidityInterval
-> StrictMaybe (Update (ShelleyLedgerEra Era))
-> Set (KeyHash 'Witness (Crypto (ShelleyLedgerEra Era)))
-> Value (Crypto (ShelleyLedgerEra Era))
-> StrictMaybe
     (ScriptIntegrityHash (Crypto (ShelleyLedgerEra Era)))
-> StrictMaybe (AuxiliaryDataHash (Crypto (ShelleyLedgerEra Era)))
-> StrictMaybe Network
-> TxBody (ShelleyLedgerEra Era)
forall era.
BabbageBody era =>
Set (TxIn (Crypto era))
-> Set (TxIn (Crypto era))
-> Set (TxIn (Crypto era))
-> StrictSeq (Sized (TxOut era))
-> StrictMaybe (Sized (TxOut era))
-> StrictMaybe Coin
-> StrictSeq (DCert (Crypto era))
-> Wdrl (Crypto era)
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> Set (KeyHash 'Witness (Crypto era))
-> Value (Crypto era)
-> StrictMaybe (ScriptIntegrityHash (Crypto era))
-> StrictMaybe (AuxiliaryDataHash (Crypto era))
-> StrictMaybe Network
-> TxBody era
Ledger.TxBody @LedgerEra
      Set (TxIn (Crypto (ShelleyLedgerEra Era)))
forall a. Monoid a => a
mempty
      Set (TxIn (Crypto (ShelleyLedgerEra Era)))
forall a. Monoid a => a
mempty
      Set (TxIn (Crypto (ShelleyLedgerEra Era)))
forall a. Monoid a => a
mempty
      StrictSeq (Sized (TxOut (ShelleyLedgerEra Era)))
forall a. StrictSeq a
Seq.empty
      StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
forall a. StrictMaybe a
SNothing
      StrictMaybe Coin
forall a. StrictMaybe a
SNothing
      StrictSeq (DCert (Crypto (ShelleyLedgerEra Era)))
forall a. StrictSeq a
Seq.empty
      (Map (RewardAcnt StandardCrypto) Coin -> Wdrl StandardCrypto
forall crypto. Map (RewardAcnt crypto) Coin -> Wdrl crypto
Wdrl Map (RewardAcnt StandardCrypto) Coin
forall a. Monoid a => a
mempty)
      Coin
forall a. Monoid a => a
mempty
      (StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing)
      StrictMaybe (Update (ShelleyLedgerEra Era))
forall a. StrictMaybe a
SNothing
      Set (KeyHash 'Witness (Crypto (ShelleyLedgerEra Era)))
forall a. Monoid a => a
mempty
      Value (Crypto (ShelleyLedgerEra Era))
forall a. Monoid a => a
mempty
      StrictMaybe (ScriptIntegrityHash (Crypto (ShelleyLedgerEra Era)))
forall a. StrictMaybe a
SNothing
      StrictMaybe (AuxiliaryDataHash (Crypto (ShelleyLedgerEra Era)))
forall a. StrictMaybe a
SNothing
      StrictMaybe Network
forall a. StrictMaybe a
SNothing

makeTxOut :: AddressAny -> Value -> TxOutDatum CtxTx Era -> ReferenceScript Era -> TxOut CtxUTxO Era
makeTxOut :: AddressAny
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxUTxO Era
makeTxOut AddressAny
addr Value
value TxOutDatum CtxTx Era
datum ReferenceScript Era
refScript =
  TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut (TxOut CtxTx Era -> TxOut CtxUTxO Era)
-> TxOut CtxTx Era -> TxOut CtxUTxO Era
forall a b. (a -> b) -> a -> b
$ AddressInEra Era
-> TxOutValue Era
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut (AddressAny -> AddressInEra Era
forall era. IsShelleyBasedEra era => AddressAny -> AddressInEra era
anyAddressInShelleyBasedEra AddressAny
addr)
                         (MultiAssetSupportedInEra Era -> Value -> TxOutValue Era
forall era. MultiAssetSupportedInEra era -> Value -> TxOutValue era
TxOutValue MultiAssetSupportedInEra Era
MultiAssetInBabbageEra Value
value)
                         TxOutDatum CtxTx Era
datum
                         ReferenceScript Era
refScript

txSigners :: Tx Era -> [Hash PaymentKey]
txSigners :: Tx Era -> [Hash PaymentKey]
txSigners (Tx TxBody Era
_ [KeyWitness Era]
wits) = [ VKey 'Witness StandardCrypto -> Hash PaymentKey
forall (r :: KeyRole). VKey r StandardCrypto -> Hash PaymentKey
toHash VKey 'Witness StandardCrypto
wit | ShelleyKeyWitness ShelleyBasedEra Era
_ (WitVKey VKey 'Witness StandardCrypto
wit SignedDSIGN
  StandardCrypto (Hash StandardCrypto EraIndependentTxBody)
_) <- [KeyWitness Era]
wits ]
  where
    toHash :: VKey r StandardCrypto -> Hash PaymentKey
toHash = KeyHash 'Payment StandardCrypto -> Hash PaymentKey
PaymentKeyHash
           (KeyHash 'Payment StandardCrypto -> Hash PaymentKey)
-> (VKey r StandardCrypto -> KeyHash 'Payment StandardCrypto)
-> VKey r StandardCrypto
-> Hash PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey 'Payment StandardCrypto -> KeyHash 'Payment StandardCrypto
forall crypto (kd :: KeyRole).
Crypto crypto =>
VKey kd crypto -> KeyHash kd crypto
hashKey
           (VKey 'Payment StandardCrypto -> KeyHash 'Payment StandardCrypto)
-> (VKey r StandardCrypto -> VKey 'Payment StandardCrypto)
-> VKey r StandardCrypto
-> KeyHash 'Payment StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey r StandardCrypto -> VKey 'Payment StandardCrypto
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto
       (r' :: KeyRole).
HasKeyRole a =>
a r crypto -> a r' crypto
coerceKeyRole

txInputs :: Tx Era -> [TxIn]
txInputs :: Tx Era -> [TxIn]
txInputs (Tx (TxBody TxBodyContent ViewTx Era
body) [KeyWitness Era]
_) = ((TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era)) -> TxIn)
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era)) -> TxIn
forall a b. (a, b) -> a
fst ([(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))] -> [TxIn])
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))] -> [TxIn]
forall a b. (a -> b) -> a -> b
$ TxBodyContent ViewTx Era
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))]
forall build era. TxBodyContent build era -> TxIns build era
txIns TxBodyContent ViewTx Era
body

txOutputs :: Tx Era -> [TxOut CtxTx Era]
txOutputs :: Tx Era -> [TxOut CtxTx Era]
txOutputs (Tx (TxBody TxBodyContent ViewTx Era
body) [KeyWitness Era]
_) = TxBodyContent ViewTx Era -> [TxOut CtxTx Era]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
txOuts TxBodyContent ViewTx Era
body

-- | Check if a value is less or equal than another value.
leqValue :: Value -> Value -> Bool
leqValue :: Value -> Value -> Bool
leqValue Value
v Value
v' = ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
<= Quantity
0) (Quantity -> Bool)
-> ((AssetId, Quantity) -> Quantity) -> (AssetId, Quantity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId, Quantity) -> Quantity
forall a b. (a, b) -> b
snd) (Value -> [(AssetId, Quantity)]
valueToList (Value -> [(AssetId, Quantity)]) -> Value -> [(AssetId, Quantity)]
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
v')

-- | Keep only the Ada part of a value.
projectAda :: Value -> Value
projectAda :: Value -> Value
projectAda = Lovelace -> Value
lovelaceToValue (Lovelace -> Value) -> (Value -> Lovelace) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Lovelace
selectLovelace

-- TODO: transactions can fail for different reasons. Sometimes they fail with
-- a "translation error". Translation errors should probably be treated as test
-- failures not as validation failing - it's after all not validation failing!

-- | The result of validating a transaction. In case of failure, it includes a list
--   of reasons.
data ValidityReport = ValidityReport
  { ValidityReport -> Bool
valid  :: Bool
  , ValidityReport -> [[Char]]
errors :: [String]
  } deriving stock (Eq ValidityReport
Eq ValidityReport
-> (ValidityReport -> ValidityReport -> Ordering)
-> (ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> ValidityReport)
-> (ValidityReport -> ValidityReport -> ValidityReport)
-> Ord ValidityReport
ValidityReport -> ValidityReport -> Bool
ValidityReport -> ValidityReport -> Ordering
ValidityReport -> ValidityReport -> ValidityReport
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ValidityReport -> ValidityReport -> ValidityReport
$cmin :: ValidityReport -> ValidityReport -> ValidityReport
max :: ValidityReport -> ValidityReport -> ValidityReport
$cmax :: ValidityReport -> ValidityReport -> ValidityReport
>= :: ValidityReport -> ValidityReport -> Bool
$c>= :: ValidityReport -> ValidityReport -> Bool
> :: ValidityReport -> ValidityReport -> Bool
$c> :: ValidityReport -> ValidityReport -> Bool
<= :: ValidityReport -> ValidityReport -> Bool
$c<= :: ValidityReport -> ValidityReport -> Bool
< :: ValidityReport -> ValidityReport -> Bool
$c< :: ValidityReport -> ValidityReport -> Bool
compare :: ValidityReport -> ValidityReport -> Ordering
$ccompare :: ValidityReport -> ValidityReport -> Ordering
$cp1Ord :: Eq ValidityReport
Ord, ValidityReport -> ValidityReport -> Bool
(ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> Bool) -> Eq ValidityReport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidityReport -> ValidityReport -> Bool
$c/= :: ValidityReport -> ValidityReport -> Bool
== :: ValidityReport -> ValidityReport -> Bool
$c== :: ValidityReport -> ValidityReport -> Bool
Eq, Int -> ValidityReport -> ShowS
[ValidityReport] -> ShowS
ValidityReport -> [Char]
(Int -> ValidityReport -> ShowS)
-> (ValidityReport -> [Char])
-> ([ValidityReport] -> ShowS)
-> Show ValidityReport
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ValidityReport] -> ShowS
$cshowList :: [ValidityReport] -> ShowS
show :: ValidityReport -> [Char]
$cshow :: ValidityReport -> [Char]
showsPrec :: Int -> ValidityReport -> ShowS
$cshowsPrec :: Int -> ValidityReport -> ShowS
Show)

-- NOTE: this function ignores the execution units associated with
-- the scripts in the Tx. That way we don't have to care about computing
-- the right values in the threat model (as this is not our main concern here).
--
-- This also means that if we were to want to deal with execution units in the threat
-- modelling framework we would need to be a bit careful and figure out some abstractions
-- that make it make sense (and check the budgets here).
--
-- Stolen from Hydra
validateTx :: ProtocolParameters -> Tx Era -> UTxO Era -> ValidityReport
validateTx :: ProtocolParameters -> Tx Era -> UTxO Era -> ValidityReport
validateTx ProtocolParameters
pparams Tx Era
tx UTxO Era
utxos = case Either
  TransactionValidityError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
result of
  Left TransactionValidityError
e -> Bool -> [[Char]] -> ValidityReport
ValidityReport Bool
False [TransactionValidityError -> [Char]
forall a. Show a => a -> [Char]
show TransactionValidityError
e]
  Right Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
report -> Bool -> [[Char]] -> ValidityReport
ValidityReport ((Either ScriptExecutionError ExecutionUnits -> Bool)
-> [Either ScriptExecutionError ExecutionUnits] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isRight (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
report))
                                 [ScriptExecutionError -> [Char]
forall a. Show a => a -> [Char]
show ScriptExecutionError
e | Left ScriptExecutionError
e <- Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
report]
  where
    result :: Either
  TransactionValidityError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
result = EraInMode Era CardanoMode
-> SystemStart
-> EraHistory CardanoMode
-> ProtocolParameters
-> UTxO Era
-> TxBody Era
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall era mode.
EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> UTxO era
-> TxBody era
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evaluateTransactionExecutionUnits
                EraInMode Era CardanoMode
BabbageEraInCardanoMode
                SystemStart
systemStart
                EraHistory CardanoMode
eraHistory
                ProtocolParameters
pparams
                UTxO Era
utxos
                (Tx Era -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx Era
tx)
    eraHistory :: EraHistory CardanoMode
    eraHistory :: EraHistory CardanoMode
eraHistory = ConsensusMode CardanoMode
-> Interpreter (CardanoEras StandardCrypto)
-> EraHistory CardanoMode
forall mode (xs :: [*]).
(ConsensusBlockForMode mode ~ HardForkBlock xs) =>
ConsensusMode mode -> Interpreter xs -> EraHistory mode
EraHistory ConsensusMode CardanoMode
CardanoMode (Summary (CardanoEras StandardCrypto)
-> Interpreter (CardanoEras StandardCrypto)
forall (xs :: [*]). Summary xs -> Interpreter xs
mkInterpreter Summary (CardanoEras StandardCrypto)
summary)

    summary :: Summary (CardanoEras StandardCrypto)
    summary :: Summary (CardanoEras StandardCrypto)
summary =
      NonEmpty (CardanoEras StandardCrypto) EraSummary
-> Summary (CardanoEras StandardCrypto)
forall (xs :: [*]). NonEmpty xs EraSummary -> Summary xs
Summary (NonEmpty (CardanoEras StandardCrypto) EraSummary
 -> Summary (CardanoEras StandardCrypto))
-> (EraSummary -> NonEmpty (CardanoEras StandardCrypto) EraSummary)
-> EraSummary
-> Summary (CardanoEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraSummary -> NonEmpty (CardanoEras StandardCrypto) EraSummary
forall b x (xs :: [*]). b -> NonEmpty (x : xs) b
NonEmptyOne (EraSummary -> Summary (CardanoEras StandardCrypto))
-> EraSummary -> Summary (CardanoEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$
        EraSummary :: Bound -> EraEnd -> EraParams -> EraSummary
EraSummary
          { eraStart :: Bound
eraStart = Bound
initBound
          , eraEnd :: EraEnd
eraEnd = EraEnd
EraUnbounded
          , eraParams :: EraParams
eraParams =
              EraParams :: EpochSize -> SlotLength -> SafeZone -> EraParams
EraParams
                { eraEpochSize :: EpochSize
eraEpochSize = EpochSize
epochSize
                , eraSlotLength :: SlotLength
eraSlotLength = SlotLength
slotLength
                , eraSafeZone :: SafeZone
eraSafeZone = SafeZone
UnsafeIndefiniteSafeZone
                }
          }

    epochSize :: EpochSize
    epochSize :: EpochSize
epochSize = Word64 -> EpochSize
EpochSize Word64
100

    slotLength :: SlotLength
    slotLength :: SlotLength
slotLength = NominalDiffTime -> SlotLength
mkSlotLength NominalDiffTime
1

    systemStart :: SystemStart
    systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime
posixSecondsToUTCTime NominalDiffTime
0

-- | Keep only UTxOs mentioned in the given transaction.
restrictUTxO :: Tx Era -> UTxO Era -> UTxO Era
restrictUTxO :: Tx Era -> UTxO Era -> UTxO Era
restrictUTxO (Tx (TxBody TxBodyContent{[(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))]
[TxOut CtxTx Era]
(TxValidityLowerBound Era, TxValidityUpperBound Era)
BuildTxWith ViewTx (Maybe ProtocolParameters)
TxAuxScripts Era
TxCertificates ViewTx Era
TxExtraKeyWitnesses Era
TxFee Era
TxInsCollateral Era
TxInsReference ViewTx Era
TxMetadataInEra Era
TxMintValue ViewTx Era
TxReturnCollateral CtxTx Era
TxScriptValidity Era
TxTotalCollateral Era
TxUpdateProposal Era
TxWithdrawals ViewTx Era
txWithdrawals :: forall build era.
TxBodyContent build era -> TxWithdrawals build era
txValidityRange :: forall build era.
TxBodyContent build era
-> (TxValidityLowerBound era, TxValidityUpperBound era)
txUpdateProposal :: forall build era. TxBodyContent build era -> TxUpdateProposal era
txTotalCollateral :: forall build era. TxBodyContent build era -> TxTotalCollateral era
txScriptValidity :: forall build era. TxBodyContent build era -> TxScriptValidity era
txReturnCollateral :: forall build era.
TxBodyContent build era -> TxReturnCollateral CtxTx era
txProtocolParams :: forall build era.
TxBodyContent build era
-> BuildTxWith build (Maybe ProtocolParameters)
txMintValue :: forall build era. TxBodyContent build era -> TxMintValue build era
txMetadata :: forall build era. TxBodyContent build era -> TxMetadataInEra era
txInsReference :: forall build era.
TxBodyContent build era -> TxInsReference build era
txInsCollateral :: forall build era. TxBodyContent build era -> TxInsCollateral era
txFee :: forall build era. TxBodyContent build era -> TxFee era
txExtraKeyWits :: forall build era.
TxBodyContent build era -> TxExtraKeyWitnesses era
txCertificates :: forall build era.
TxBodyContent build era -> TxCertificates build era
txAuxScripts :: forall build era. TxBodyContent build era -> TxAuxScripts era
txScriptValidity :: TxScriptValidity Era
txMintValue :: TxMintValue ViewTx Era
txUpdateProposal :: TxUpdateProposal Era
txCertificates :: TxCertificates ViewTx Era
txWithdrawals :: TxWithdrawals ViewTx Era
txProtocolParams :: BuildTxWith ViewTx (Maybe ProtocolParameters)
txExtraKeyWits :: TxExtraKeyWitnesses Era
txAuxScripts :: TxAuxScripts Era
txMetadata :: TxMetadataInEra Era
txValidityRange :: (TxValidityLowerBound Era, TxValidityUpperBound Era)
txFee :: TxFee Era
txReturnCollateral :: TxReturnCollateral CtxTx Era
txTotalCollateral :: TxTotalCollateral Era
txOuts :: [TxOut CtxTx Era]
txInsReference :: TxInsReference ViewTx Era
txInsCollateral :: TxInsCollateral Era
txIns :: [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))]
txOuts :: forall build era. TxBodyContent build era -> [TxOut CtxTx era]
txIns :: forall build era. TxBodyContent build era -> TxIns build era
..}) [KeyWitness Era]
_) (UTxO Map TxIn (TxOut CtxUTxO Era)
utxo) =
  Map TxIn (TxOut CtxUTxO Era) -> UTxO Era
forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
UTxO (Map TxIn (TxOut CtxUTxO Era) -> UTxO Era)
-> Map TxIn (TxOut CtxUTxO Era) -> UTxO Era
forall a b. (a -> b) -> a -> b
$ (TxIn -> TxOut CtxUTxO Era -> Bool)
-> Map TxIn (TxOut CtxUTxO Era) -> Map TxIn (TxOut CtxUTxO Era)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\ TxIn
k TxOut CtxUTxO Era
_ -> TxIn
k TxIn -> [TxIn] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era)) -> TxIn)
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era)) -> TxIn
forall a b. (a, b) -> a
fst [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))]
txIns) Map TxIn (TxOut CtxUTxO Era)
utxo

convValidityInterval
  :: (TxValidityLowerBound era, TxValidityUpperBound era)
  -> ValidityInterval
convValidityInterval :: (TxValidityLowerBound era, TxValidityUpperBound era)
-> ValidityInterval
convValidityInterval (TxValidityLowerBound era
lowerBound, TxValidityUpperBound era
upperBound) =
  ValidityInterval :: StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval
    { invalidBefore :: StrictMaybe SlotNo
invalidBefore = case TxValidityLowerBound era
lowerBound of
                        TxValidityLowerBound era
TxValidityNoLowerBound   -> StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
                        TxValidityLowerBound ValidityLowerBoundSupportedInEra era
_ SlotNo
s -> SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
s
    , invalidHereafter :: StrictMaybe SlotNo
invalidHereafter = case TxValidityUpperBound era
upperBound of
                           TxValidityNoUpperBound ValidityNoUpperBoundSupportedInEra era
_ -> StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
                           TxValidityUpperBound ValidityUpperBoundSupportedInEra era
_ SlotNo
s -> SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
s
    }