{-# OPTIONS_GHC -Wno-orphans #-}
module Hydra.Ledger.Cardano (
module Hydra.Ledger.Cardano,
module Hydra.Ledger.Cardano.Builder,
Ledger.ShelleyGenesis (..),
Tx,
) where
import Hydra.Prelude
import Hydra.Cardano.Api hiding (initialLedgerState)
import Hydra.Ledger.Cardano.Builder
import Cardano.Api.UTxO (fromPairs, pairs)
import Cardano.Api.UTxO qualified as UTxO
import Cardano.Crypto.DSIGN qualified as CC
import Cardano.Ledger.Api (updateTxBodyL)
import Cardano.Ledger.Babbage.Tx qualified as Ledger
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Binary (decCBOR, decodeFullAnnotator, serialize')
import Cardano.Ledger.Credential qualified as Ledger
import Cardano.Ledger.Shelley.API.Mempool qualified as Ledger
import Cardano.Ledger.Shelley.Genesis qualified as Ledger
import Cardano.Ledger.Shelley.LedgerState qualified as Ledger
import Cardano.Ledger.Shelley.Rules qualified as Ledger
import Cardano.Ledger.Shelley.UTxO qualified as Ledger
import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Encoding qualified as CBOR
import Control.Lens (set)
import Control.Monad (foldM)
import Data.Aeson (object, (.:), (.:?), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (withObject)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.Default (def)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromJust)
import Data.Text.Lazy.Builder (toLazyText)
import Formatting.Buildable (build)
import Hydra.Contract.Head qualified as Head
import Hydra.Ledger (ChainSlot (..), IsTx (..), Ledger (..), ValidationError (..))
import PlutusLedgerApi.V2 (fromBuiltin)
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.QuickCheck (
choose,
getSize,
listOf,
oneof,
scale,
shrinkList,
shrinkMapBy,
suchThat,
vectorOf,
)
cardanoLedger :: Ledger.Globals -> Ledger.LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger :: Globals -> LedgerEnv (ShelleyLedgerEra Era) -> Ledger Tx
cardanoLedger Globals
globals LedgerEnv (ShelleyLedgerEra Era)
ledgerEnv =
Ledger{ChainSlot
-> UTxO' (TxOut CtxUTxO Era)
-> [Tx]
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
applyTransactions :: ChainSlot
-> UTxO' (TxOut CtxUTxO Era)
-> [Tx]
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
$sel:applyTransactions:Ledger :: ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
applyTransactions}
where
applyTransactions :: ChainSlot
-> UTxO' (TxOut CtxUTxO Era)
-> [Tx]
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
applyTransactions ChainSlot
slot UTxO' (TxOut CtxUTxO Era)
utxo = \case
[] -> UTxO' (TxOut CtxUTxO Era)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
forall a b. b -> Either a b
Right UTxO' (TxOut CtxUTxO Era)
utxo
(Tx
tx : [Tx]
txs) -> do
UTxO' (TxOut CtxUTxO Era)
utxo' <- ChainSlot
-> UTxO' (TxOut CtxUTxO Era)
-> Tx
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
applyTx ChainSlot
slot UTxO' (TxOut CtxUTxO Era)
utxo Tx
tx
ChainSlot
-> UTxO' (TxOut CtxUTxO Era)
-> [Tx]
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
applyTransactions ChainSlot
slot UTxO' (TxOut CtxUTxO Era)
utxo' [Tx]
txs
applyTx :: ChainSlot
-> UTxO' (TxOut CtxUTxO Era)
-> Tx
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
applyTx (ChainSlot Natural
slot) UTxO' (TxOut CtxUTxO Era)
utxo Tx
tx =
case Globals
-> MempoolEnv (BabbageEra StandardCrypto)
-> MempoolState (BabbageEra StandardCrypto)
-> Tx (BabbageEra StandardCrypto)
-> Either
(ApplyTxError (BabbageEra StandardCrypto))
(MempoolState (BabbageEra StandardCrypto),
Validated (Tx (BabbageEra StandardCrypto)))
forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> m (MempoolState era, Validated (Tx era))
forall (m :: * -> *).
MonadError (ApplyTxError (BabbageEra StandardCrypto)) m =>
Globals
-> MempoolEnv (BabbageEra StandardCrypto)
-> MempoolState (BabbageEra StandardCrypto)
-> Tx (BabbageEra StandardCrypto)
-> m (MempoolState (BabbageEra StandardCrypto),
Validated (Tx (BabbageEra StandardCrypto)))
Ledger.applyTx Globals
globals MempoolEnv (BabbageEra StandardCrypto)
env' MempoolState (BabbageEra StandardCrypto)
memPoolState (Tx -> Tx (ShelleyLedgerEra Era)
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
AlonzoEraTx (ShelleyLedgerEra era)) =>
Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx) of
Left ApplyTxError (BabbageEra StandardCrypto)
err ->
(Tx, ValidationError)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
forall a b. a -> Either a b
Left (Tx
tx, ApplyTxError (BabbageEra StandardCrypto) -> ValidationError
toValidationError ApplyTxError (BabbageEra StandardCrypto)
err)
Right (Ledger.LedgerState{lsUTxOState :: forall era. LedgerState era -> UTxOState era
Ledger.lsUTxOState = UTxOState (BabbageEra StandardCrypto)
us}, Validated (AlonzoTx (BabbageEra StandardCrypto))
_validatedTx) ->
UTxO' (TxOut CtxUTxO Era)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
forall a b. b -> Either a b
Right (UTxO' (TxOut CtxUTxO Era)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era)))
-> (UTxO (BabbageEra StandardCrypto) -> UTxO' (TxOut CtxUTxO Era))
-> UTxO (BabbageEra StandardCrypto)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO (ShelleyLedgerEra Era) -> UTxO' (TxOut CtxUTxO Era)
UTxO (BabbageEra StandardCrypto) -> UTxO' (TxOut CtxUTxO Era)
fromLedgerUTxO (UTxO (BabbageEra StandardCrypto)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era)))
-> UTxO (BabbageEra StandardCrypto)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ UTxOState (BabbageEra StandardCrypto)
-> UTxO (BabbageEra StandardCrypto)
forall era. UTxOState era -> UTxO era
Ledger.utxosUtxo UTxOState (BabbageEra StandardCrypto)
us
where
toValidationError :: ApplyTxError (BabbageEra StandardCrypto) -> ValidationError
toValidationError = Text -> ValidationError
ValidationError (Text -> ValidationError)
-> (ApplyTxError (BabbageEra StandardCrypto) -> Text)
-> ApplyTxError (BabbageEra StandardCrypto)
-> ValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplyTxError (BabbageEra StandardCrypto) -> Text
forall b a. (Show a, IsString b) => a -> b
show
env' :: MempoolEnv (BabbageEra StandardCrypto)
env' = LedgerEnv (ShelleyLedgerEra Era)
ledgerEnv{Ledger.ledgerSlotNo = fromIntegral slot}
memPoolState :: MempoolState (BabbageEra StandardCrypto)
memPoolState =
Ledger.LedgerState
{ lsUTxOState :: UTxOState (BabbageEra StandardCrypto)
Ledger.lsUTxOState = UTxOState (BabbageEra StandardCrypto)
forall a. Default a => a
def{Ledger.utxosUtxo = toLedgerUTxO utxo}
, lsCertState :: CertState (BabbageEra StandardCrypto)
Ledger.lsCertState = CertState (BabbageEra StandardCrypto)
forall a. Default a => a
def
}
fromChainSlot :: ChainSlot -> SlotNo
fromChainSlot :: ChainSlot -> SlotNo
fromChainSlot (ChainSlot Natural
s) = Natural -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
s
instance IsTx Tx where
type TxIdType Tx = TxId
type UTxOType Tx = UTxO
type ValueType Tx = Value
txId :: Tx -> TxIdType Tx
txId = TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> (Tx -> TxBody Era) -> Tx -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody
balance :: UTxOType Tx -> ValueType Tx
balance = (TxOut CtxUTxO Era -> Value) -> UTxO' (TxOut CtxUTxO Era) -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue
hashUTxO :: UTxOType Tx -> ByteString
hashUTxO = BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin (BuiltinByteString -> ByteString)
-> (UTxO' (TxOut CtxUTxO Era) -> BuiltinByteString)
-> UTxO' (TxOut CtxUTxO Era)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOut] -> BuiltinByteString
Head.hashTxOuts ([TxOut] -> BuiltinByteString)
-> (UTxO' (TxOut CtxUTxO Era) -> [TxOut])
-> UTxO' (TxOut CtxUTxO Era)
-> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut CtxUTxO Era -> Maybe TxOut)
-> [TxOut CtxUTxO Era] -> [TxOut]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HasCallStack => TxOut CtxUTxO Era -> Maybe TxOut
TxOut CtxUTxO Era -> Maybe TxOut
toPlutusTxOut ([TxOut CtxUTxO Era] -> [TxOut])
-> (UTxO' (TxOut CtxUTxO Era) -> [TxOut CtxUTxO Era])
-> UTxO' (TxOut CtxUTxO Era)
-> [TxOut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO' (TxOut CtxUTxO Era) -> [TxOut CtxUTxO Era]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
instance ToCBOR Tx where
toCBOR :: Tx -> Encoding
toCBOR = ByteString -> Encoding
CBOR.encodeBytes (ByteString -> Encoding) -> (Tx -> ByteString) -> Tx -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> AlonzoTx (BabbageEra StandardCrypto) -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
ledgerEraVersion (AlonzoTx (BabbageEra StandardCrypto) -> ByteString)
-> (Tx -> AlonzoTx (BabbageEra StandardCrypto)) -> Tx -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> Tx (ShelleyLedgerEra Era)
Tx -> AlonzoTx (BabbageEra StandardCrypto)
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
AlonzoEraTx (ShelleyLedgerEra era)) =>
Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx
instance FromCBOR Tx where
fromCBOR :: forall s. Decoder s Tx
fromCBOR = do
ByteString
bs <- Decoder s ByteString
forall s. Decoder s ByteString
CBOR.decodeBytes
Version
-> Text
-> (forall s.
Decoder s (Annotator (AlonzoTx (BabbageEra StandardCrypto))))
-> ByteString
-> Either DecoderError (AlonzoTx (BabbageEra StandardCrypto))
forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator Version
ledgerEraVersion Text
"Tx" Decoder s (Annotator (AlonzoTx (BabbageEra StandardCrypto)))
forall s.
Decoder s (Annotator (AlonzoTx (BabbageEra StandardCrypto)))
forall a s. DecCBOR a => Decoder s a
decCBOR (ByteString -> ByteString
forall l s. LazyStrict l s => s -> l
fromStrict ByteString
bs)
Either DecoderError (AlonzoTx (BabbageEra StandardCrypto))
-> (Either DecoderError (AlonzoTx (BabbageEra StandardCrypto))
-> Decoder s Tx)
-> Decoder s Tx
forall a b. a -> (a -> b) -> b
& (DecoderError -> Decoder s Tx)
-> (AlonzoTx (BabbageEra StandardCrypto) -> Decoder s Tx)
-> Either DecoderError (AlonzoTx (BabbageEra StandardCrypto))
-> Decoder s Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(String -> Decoder s Tx
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s Tx)
-> (DecoderError -> String) -> DecoderError -> Decoder s Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String)
-> (DecoderError -> Text) -> DecoderError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text)
-> (DecoderError -> Builder) -> DecoderError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoderError -> Builder
forall p. Buildable p => p -> Builder
build)
(Tx -> Decoder s Tx
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Decoder s Tx)
-> (AlonzoTx (BabbageEra StandardCrypto) -> Tx)
-> AlonzoTx (BabbageEra StandardCrypto)
-> Decoder s Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx (ShelleyLedgerEra Era) -> Tx
AlonzoTx (BabbageEra StandardCrypto) -> Tx
fromLedgerTx)
instance ToJSON Tx where
toJSON :: Tx -> Value
toJSON Tx
tx =
let TextEnvelopeType String
envelopeType = AsType Tx -> TextEnvelopeType
forall a. HasTextEnvelope a => AsType a -> TextEnvelopeType
textEnvelopeType (Proxy Tx -> AsType Tx
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Tx))
in [Pair] -> Value
object
[ Key
"cborHex" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
tx)
, Key
"txId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx
, Key
"type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
envelopeType
, Key
"description" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
forall a. Monoid a => a
mempty
]
instance FromJSON Tx where
parseJSON :: Value -> Parser Tx
parseJSON =
String -> (Object -> Parser Tx) -> Value -> Parser Tx
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Tx" ((Object -> Parser Tx) -> Value -> Parser Tx)
-> (Object -> Parser Tx) -> Value -> Parser Tx
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
let TextEnvelopeType String
envelopeType = AsType Tx -> TextEnvelopeType
forall a. HasTextEnvelope a => AsType a -> TextEnvelopeType
textEnvelopeType (Proxy Tx -> AsType Tx
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Tx))
Text
hexText <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"cborHex"
String
ty <- Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
envelopeType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ty)
ByteString
bytes <- Text -> Parser ByteString
forall (f :: * -> *). MonadFail f => Text -> f ByteString
decodeBase16 Text
hexText
case AsType Tx -> ByteString -> Either DecoderError Tx
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR (Proxy Tx -> AsType Tx
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Tx)) ByteString
bytes of
Left DecoderError
e -> String -> Parser Tx
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Tx) -> String -> Parser Tx
forall a b. (a -> b) -> a -> b
$ DecoderError -> String
forall b a. (Show a, IsString b) => a -> b
show DecoderError
e
Right Tx
tx ->
(Object
o Object -> Key -> Parser (Maybe TxId)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"txId") Parser (Maybe TxId) -> (Maybe TxId -> Parser Tx) -> Parser Tx
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TxId
Nothing -> Tx -> Parser Tx
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx
Just TxId
txid' -> do
Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TxId
txid' TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx)
Tx -> Parser Tx
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx
instance Arbitrary Tx where
arbitrary :: Gen Tx
arbitrary = Tx (ShelleyLedgerEra Era) -> Tx
AlonzoTx (BabbageEra StandardCrypto) -> Tx
fromLedgerTx (AlonzoTx (BabbageEra StandardCrypto) -> Tx)
-> (AlonzoTx (BabbageEra StandardCrypto)
-> AlonzoTx (BabbageEra StandardCrypto))
-> AlonzoTx (BabbageEra StandardCrypto)
-> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx (BabbageEra StandardCrypto)
-> AlonzoTx (BabbageEra StandardCrypto)
forall {era}.
(Assert
(OrdCond
(CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
ProtVerIsInBounds
"at most"
era
8
(OrdCond (CmpNat (ProtVerLow era) 8) 'True 'True 'False),
ShelleyEraTxBody era) =>
AlonzoTx era -> AlonzoTx era
withoutProtocolUpdates (AlonzoTx (BabbageEra StandardCrypto) -> Tx)
-> Gen (AlonzoTx (BabbageEra StandardCrypto)) -> Gen Tx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (AlonzoTx (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
where
withoutProtocolUpdates :: AlonzoTx era -> AlonzoTx era
withoutProtocolUpdates tx :: AlonzoTx era
tx@(Ledger.AlonzoTx TxBody era
body TxWits era
_ IsValid
_ StrictMaybe (TxAuxData era)
_) =
let body' :: TxBody era
body' = TxBody era
body TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& ASetter
(TxBody era)
(TxBody era)
(StrictMaybe (Update era))
(StrictMaybe (Update era))
-> StrictMaybe (Update era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
(TxBody era)
(TxBody era)
(StrictMaybe (Update era))
(StrictMaybe (Update era))
forall era.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
Lens' (TxBody era) (StrictMaybe (Update era))
updateTxBodyL StrictMaybe (Update era)
forall a. StrictMaybe a
SNothing
in AlonzoTx era
tx{Ledger.body = body'}
mkSimpleTx ::
(TxIn, TxOut CtxUTxO) ->
(AddressInEra, Value) ->
SigningKey PaymentKey ->
Either TxBodyError Tx
mkSimpleTx :: (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn
txin, TxOut AddressInEra
owner Value
valueIn TxOutDatum CtxUTxO
datum ReferenceScript
refScript) (AddressInEra
recipient, Value
valueOut) SigningKey PaymentKey
sk = do
TxBody Era
body <- TxBodyContent BuildTx -> Either TxBodyError (TxBody Era)
createAndValidateTransactionBody TxBodyContent BuildTx
bodyContent
let witnesses :: [KeyWitness]
witnesses = [TxBody Era -> ShelleyWitnessSigningKey -> KeyWitness
makeShelleyKeyWitness TxBody Era
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
sk)]
Tx -> Either TxBodyError Tx
forall a. a -> Either TxBodyError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either TxBodyError Tx) -> Tx -> Either TxBodyError Tx
forall a b. (a -> b) -> a -> b
$ [KeyWitness] -> TxBody Era -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [KeyWitness]
witnesses TxBody Era
body
where
bodyContent :: TxBodyContent BuildTx
bodyContent =
TxBodyContent BuildTx
emptyTxBody
{ txIns = [(txin, BuildTxWith $ KeyWitness KeyWitnessForSpending)]
, txOuts = outs
, txFee = TxFeeExplicit fee
}
outs :: [TxOut CtxTx]
outs =
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut @CtxTx AddressInEra
recipient Value
valueOut TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
TxOut CtxTx -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. a -> [a] -> [a]
: [ forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut @CtxTx
AddressInEra
owner
(Value
valueIn Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
valueOut)
(TxOutDatum CtxUTxO -> TxOutDatum CtxTx
forall era. TxOutDatum CtxUTxO era -> TxOutDatum CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOutDatum CtxUTxO
datum)
ReferenceScript
refScript
| Value
valueOut Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
valueIn
]
fee :: Coin
fee = Integer -> Coin
Coin Integer
0
mkRangedTx ::
(TxIn, TxOut CtxUTxO) ->
(AddressInEra, Value) ->
SigningKey PaymentKey ->
(Maybe TxValidityLowerBound, Maybe TxValidityUpperBound) ->
Either TxBodyError Tx
mkRangedTx :: (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> (Maybe TxValidityLowerBound, Maybe TxValidityUpperBound)
-> Either TxBodyError Tx
mkRangedTx (TxIn
txin, TxOut AddressInEra
owner Value
valueIn TxOutDatum CtxUTxO
datum ReferenceScript
refScript) (AddressInEra
recipient, Value
valueOut) SigningKey PaymentKey
sk (Maybe TxValidityLowerBound
validityLowerBound, Maybe TxValidityUpperBound
validityUpperBound) = do
TxBody Era
body <- TxBodyContent BuildTx -> Either TxBodyError (TxBody Era)
createAndValidateTransactionBody TxBodyContent BuildTx
bodyContent
let witnesses :: [KeyWitness]
witnesses = [TxBody Era -> ShelleyWitnessSigningKey -> KeyWitness
makeShelleyKeyWitness TxBody Era
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
sk)]
Tx -> Either TxBodyError Tx
forall a. a -> Either TxBodyError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either TxBodyError Tx) -> Tx -> Either TxBodyError Tx
forall a b. (a -> b) -> a -> b
$ [KeyWitness] -> TxBody Era -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [KeyWitness]
witnesses TxBody Era
body
where
bodyContent :: TxBodyContent BuildTx
bodyContent =
TxBodyContent BuildTx
emptyTxBody
{ txIns = [(txin, BuildTxWith $ KeyWitness KeyWitnessForSpending)]
, txOuts =
TxOut @CtxTx recipient valueOut TxOutDatumNone ReferenceScriptNone
: [ TxOut @CtxTx
owner
(valueIn <> negateValue valueOut)
(toTxContext datum)
refScript
| valueOut /= valueIn
]
, txFee = TxFeeExplicit $ Coin 0
, txValidityLowerBound = fromMaybe TxValidityNoLowerBound validityLowerBound
, txValidityUpperBound = fromMaybe TxValidityNoUpperBound validityUpperBound
}
adjustUTxO :: Tx -> UTxO -> UTxO
adjustUTxO :: Tx -> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
adjustUTxO Tx
tx UTxO' (TxOut CtxUTxO Era)
utxo =
let txid :: TxIdType Tx
txid = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx
consumed :: [TxIn]
consumed = Tx -> [TxIn]
forall era. Tx era -> [TxIn]
txIns' Tx
tx
produced :: UTxO' (TxOut CtxUTxO Era)
produced =
TxOut CtxTx -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext
(TxOut CtxTx -> TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxTx) -> UTxO' (TxOut CtxUTxO Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, TxOut CtxTx)] -> UTxO' (TxOut CtxTx)
forall out. [(TxIn, out)] -> UTxO' out
fromPairs ((\(TxOut CtxTx
txout, Word
ix) -> (TxId -> TxIx -> TxIn
TxIn TxId
TxIdType Tx
txid (Word -> TxIx
TxIx Word
ix), TxOut CtxTx
txout)) ((TxOut CtxTx, Word) -> (TxIn, TxOut CtxTx))
-> [(TxOut CtxTx, Word)] -> [(TxIn, TxOut CtxTx)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOut CtxTx] -> [Word] -> [(TxOut CtxTx, Word)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Tx -> [TxOut CtxTx]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx) [Word
0 ..])
utxo' :: UTxO' (TxOut CtxUTxO Era)
utxo' = [(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era)
forall out. [(TxIn, out)] -> UTxO' out
fromPairs ([(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ ((TxIn, TxOut CtxUTxO Era) -> Bool)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIn
txin, TxOut CtxUTxO Era
_) -> TxIn
txin TxIn -> [TxIn] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [TxIn]
consumed) ([(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)])
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
pairs UTxO' (TxOut CtxUTxO Era)
utxo
in UTxO' (TxOut CtxUTxO Era)
utxo' UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era)
produced
genSigningKey :: Gen (SigningKey PaymentKey)
genSigningKey :: Gen (SigningKey PaymentKey)
genSigningKey = do
SignKeyDSIGN Ed25519DSIGN
sk <- Maybe (SignKeyDSIGN Ed25519DSIGN) -> SignKeyDSIGN Ed25519DSIGN
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (SignKeyDSIGN Ed25519DSIGN) -> SignKeyDSIGN Ed25519DSIGN)
-> ([Word8] -> Maybe (SignKeyDSIGN Ed25519DSIGN))
-> [Word8]
-> SignKeyDSIGN Ed25519DSIGN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (SignKeyDSIGN Ed25519DSIGN)
forall v. DSIGNAlgorithm v => ByteString -> Maybe (SignKeyDSIGN v)
CC.rawDeserialiseSignKeyDSIGN (ByteString -> Maybe (SignKeyDSIGN Ed25519DSIGN))
-> ([Word8] -> ByteString)
-> [Word8]
-> Maybe (SignKeyDSIGN Ed25519DSIGN)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
[Item ByteString] -> ByteString
forall l. IsList l => [Item l] -> l
fromList ([Word8] -> SignKeyDSIGN Ed25519DSIGN)
-> Gen [Word8] -> Gen (SignKeyDSIGN Ed25519DSIGN)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
32 Gen Word8
forall a. Arbitrary a => Gen a
arbitrary
SigningKey PaymentKey -> Gen (SigningKey PaymentKey)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignKeyDSIGN StandardCrypto -> SigningKey PaymentKey
PaymentSigningKey SignKeyDSIGN StandardCrypto
SignKeyDSIGN Ed25519DSIGN
sk)
genVerificationKey :: Gen (VerificationKey PaymentKey)
genVerificationKey :: Gen (VerificationKey PaymentKey)
genVerificationKey = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> Gen (SigningKey PaymentKey) -> Gen (VerificationKey PaymentKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SigningKey PaymentKey)
genSigningKey
genKeyPair :: Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair :: Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair = do
SigningKey PaymentKey
sk <- Gen (SigningKey PaymentKey)
genSigningKey
(VerificationKey PaymentKey, SigningKey PaymentKey)
-> Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk, SigningKey PaymentKey
sk)
genSequenceOfSimplePaymentTransactions :: Gen (UTxO, [Tx])
genSequenceOfSimplePaymentTransactions :: Gen (UTxO' (TxOut CtxUTxO Era), [Tx])
genSequenceOfSimplePaymentTransactions = do
Int
n <- Gen Int
getSize
Int
numTxs <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
n)
Int -> Gen (UTxO' (TxOut CtxUTxO Era), [Tx])
genFixedSizeSequenceOfSimplePaymentTransactions Int
numTxs
genFixedSizeSequenceOfSimplePaymentTransactions :: Int -> Gen (UTxO, [Tx])
genFixedSizeSequenceOfSimplePaymentTransactions :: Int -> Gen (UTxO' (TxOut CtxUTxO Era), [Tx])
genFixedSizeSequenceOfSimplePaymentTransactions Int
numTxs = do
keyPair :: (VerificationKey PaymentKey, SigningKey PaymentKey)
keyPair@(VerificationKey PaymentKey
vk, SigningKey PaymentKey
_) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
UTxO' (TxOut CtxUTxO Era)
utxo <- VerificationKey PaymentKey -> Gen (UTxO' (TxOut CtxUTxO Era))
genOneUTxOFor VerificationKey PaymentKey
vk
[Tx]
txs <-
[Tx] -> [Tx]
forall a. [a] -> [a]
reverse
([Tx] -> [Tx])
-> ((UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> [Tx])
-> (UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> [Tx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> [Tx]
forall {a} {b} {c}. (a, b, c) -> c
thrd
((UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> [Tx])
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> Gen [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> Int
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx]))
-> (UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> [Int]
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (NetworkId
-> (UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> Int
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
generateOneTransfer NetworkId
testNetworkId) (UTxO' (TxOut CtxUTxO Era)
utxo, (VerificationKey PaymentKey, SigningKey PaymentKey)
keyPair, []) [Int
1 .. Int
numTxs]
(UTxO' (TxOut CtxUTxO Era), [Tx])
-> Gen (UTxO' (TxOut CtxUTxO Era), [Tx])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut CtxUTxO Era)
utxo, [Tx]
txs)
where
thrd :: (a, b, c) -> c
thrd (a
_, b
_, c
c) = c
c
testNetworkId :: NetworkId
testNetworkId = NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId) -> NetworkMagic -> NetworkId
forall a b. (a -> b) -> a -> b
$ Word32 -> NetworkMagic
NetworkMagic Word32
42
generateOneTransfer ::
NetworkId ->
(UTxO, (VerificationKey PaymentKey, SigningKey PaymentKey), [Tx]) ->
Int ->
Gen (UTxO, (VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
generateOneTransfer :: NetworkId
-> (UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> Int
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
generateOneTransfer NetworkId
networkId (UTxO' (TxOut CtxUTxO Era)
utxo, (VerificationKey PaymentKey
_, SigningKey PaymentKey
sender), [Tx]
txs) Int
_ = do
(VerificationKey PaymentKey, SigningKey PaymentKey)
recipient <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
case UTxO' (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO Era)
utxo of
[(TxIn, TxOut CtxUTxO Era)
txin] ->
case (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn, TxOut CtxUTxO Era)
txin (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId ((VerificationKey PaymentKey, SigningKey PaymentKey)
-> VerificationKey PaymentKey
forall a b. (a, b) -> a
fst (VerificationKey PaymentKey, SigningKey PaymentKey)
recipient), forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance @Tx UTxO' (TxOut CtxUTxO Era)
UTxOType Tx
utxo) SigningKey PaymentKey
sender of
Left TxBodyError
e -> Text
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx]))
-> Text
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
forall a b. (a -> b) -> a -> b
$ Text
"Tx construction failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxBodyError -> Text
forall b a. (Show a, IsString b) => a -> b
show TxBodyError
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", utxo: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era) -> Text
forall b a. (Show a, IsString b) => a -> b
show UTxO' (TxOut CtxUTxO Era)
utxo
Right Tx
tx ->
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> UTxO' (TxOut CtxUTxO Era)
utxoFromTx Tx
tx, (VerificationKey PaymentKey, SigningKey PaymentKey)
recipient, Tx
tx Tx -> [Tx] -> [Tx]
forall a. a -> [a] -> [a]
: [Tx]
txs)
[(TxIn, TxOut CtxUTxO Era)]
_ ->
Text
-> Gen
(UTxO' (TxOut CtxUTxO Era),
(VerificationKey PaymentKey, SigningKey PaymentKey), [Tx])
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Couldn't generate transaction sequence: need exactly one UTXO."
genOutput ::
forall ctx.
VerificationKey PaymentKey ->
Gen (TxOut ctx)
genOutput :: forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutput VerificationKey PaymentKey
vk = do
Value
value <- Gen Value
genValue
TxOut ctx -> Gen (TxOut ctx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut ctx -> Gen (TxOut ctx)) -> TxOut ctx -> Gen (TxOut ctx)
forall a b. (a -> b) -> a -> b
$ AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress (NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId) -> NetworkMagic -> NetworkId
forall a b. (a -> b) -> a -> b
$ Word32 -> NetworkMagic
NetworkMagic Word32
42) VerificationKey PaymentKey
vk) Value
value TxOutDatum ctx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
genTxOutAdaOnly :: VerificationKey PaymentKey -> Gen (TxOut ctx)
genTxOutAdaOnly :: forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genTxOutAdaOnly VerificationKey PaymentKey
vk = do
Value
value <- Coin -> Value
lovelaceToValue (Coin -> Value) -> (Integer -> Coin) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin (Integer -> Value) -> Gen Integer -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int) -> Gen Integer -> Gen Integer
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8) Gen Integer
forall a. Arbitrary a => Gen a
arbitrary Gen Integer -> (Integer -> Bool) -> Gen Integer
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0)
TxOut ctx -> Gen (TxOut ctx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut ctx -> Gen (TxOut ctx)) -> TxOut ctx -> Gen (TxOut ctx)
forall a b. (a -> b) -> a -> b
$ AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress (NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId) -> NetworkMagic -> NetworkId
forall a b. (a -> b) -> a -> b
$ Word32 -> NetworkMagic
NetworkMagic Word32
42) VerificationKey PaymentKey
vk) Value
value TxOutDatum ctx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
genUTxOAdaOnlyOfSize :: Int -> Gen UTxO
genUTxOAdaOnlyOfSize :: Int -> Gen (UTxO' (TxOut CtxUTxO Era))
genUTxOAdaOnlyOfSize Int
numUTxO =
[UTxO' (TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era)
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([UTxO' (TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era))
-> Gen [UTxO' (TxOut CtxUTxO Era)]
-> Gen (UTxO' (TxOut CtxUTxO Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Gen (UTxO' (TxOut CtxUTxO Era))
-> Gen [UTxO' (TxOut CtxUTxO Era)]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
numUTxO ((TxIn, TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton ((TxIn, TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era))
-> Gen (TxIn, TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxIn, TxOut CtxUTxO Era)
forall {ctx}. Gen (TxIn, TxOut ctx)
gen)
where
gen :: Gen (TxIn, TxOut ctx)
gen = (,) (TxIn -> TxOut ctx -> (TxIn, TxOut ctx))
-> Gen TxIn -> Gen (TxOut ctx -> (TxIn, TxOut ctx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary Gen (TxOut ctx -> (TxIn, TxOut ctx))
-> Gen (TxOut ctx) -> Gen (TxIn, TxOut ctx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (VerificationKey PaymentKey -> Gen (TxOut ctx)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genTxOutAdaOnly (VerificationKey PaymentKey -> Gen (TxOut ctx))
-> Gen (VerificationKey PaymentKey) -> Gen (TxOut ctx)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary)
genUTxOAlonzo :: Gen UTxO
genUTxOAlonzo :: Gen (UTxO' (TxOut CtxUTxO Era))
genUTxOAlonzo = do
[(TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))]
utxoMap <- Map
(TxIn (EraCrypto (BabbageEra StandardCrypto)))
(TxOut (BabbageEra StandardCrypto))
-> [(TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map
(TxIn (EraCrypto (BabbageEra StandardCrypto)))
(TxOut (BabbageEra StandardCrypto))
-> [(TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))])
-> (UTxO (BabbageEra StandardCrypto)
-> Map
(TxIn (EraCrypto (BabbageEra StandardCrypto)))
(TxOut (BabbageEra StandardCrypto)))
-> UTxO (BabbageEra StandardCrypto)
-> [(TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO (BabbageEra StandardCrypto)
-> Map
(TxIn (EraCrypto (BabbageEra StandardCrypto)))
(TxOut (BabbageEra StandardCrypto))
forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
Ledger.unUTxO (UTxO (BabbageEra StandardCrypto)
-> [(TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))])
-> Gen (UTxO (BabbageEra StandardCrypto))
-> Gen
[(TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (UTxO (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
([(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era))
-> Gen [(TxIn, TxOut CtxUTxO Era)]
-> Gen (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era)
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs (Gen [(TxIn, TxOut CtxUTxO Era)]
-> Gen (UTxO' (TxOut CtxUTxO Era)))
-> (((TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))
-> Gen (TxIn, TxOut CtxUTxO Era))
-> Gen [(TxIn, TxOut CtxUTxO Era)])
-> ((TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))
-> Gen (TxIn, TxOut CtxUTxO Era))
-> Gen (UTxO' (TxOut CtxUTxO Era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))]
-> ((TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))
-> Gen (TxIn, TxOut CtxUTxO Era))
-> Gen [(TxIn, TxOut CtxUTxO Era)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))]
utxoMap (((TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))
-> Gen (TxIn, TxOut CtxUTxO Era))
-> Gen (UTxO' (TxOut CtxUTxO Era)))
-> ((TxIn (EraCrypto (BabbageEra StandardCrypto)),
TxOut (BabbageEra StandardCrypto))
-> Gen (TxIn, TxOut CtxUTxO Era))
-> Gen (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ \(TxIn (EraCrypto (BabbageEra StandardCrypto))
_, TxOut (BabbageEra StandardCrypto)
o) -> do
TxIn
i <- Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
(TxIn, TxOut CtxUTxO Era) -> Gen (TxIn, TxOut CtxUTxO Era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn
i, TxOut (ShelleyLedgerEra Era) -> TxOut CtxUTxO Era
forall ctx. TxOut (ShelleyLedgerEra Era) -> TxOut ctx Era
fromLedgerTxOut TxOut (ShelleyLedgerEra Era)
TxOut (BabbageEra StandardCrypto)
o)
genUTxOSized :: Int -> Gen UTxO
genUTxOSized :: Int -> Gen (UTxO' (TxOut CtxUTxO Era))
genUTxOSized Int
numUTxO =
[UTxO' (TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era)
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([UTxO' (TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era))
-> Gen [UTxO' (TxOut CtxUTxO Era)]
-> Gen (UTxO' (TxOut CtxUTxO Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Gen (UTxO' (TxOut CtxUTxO Era))
-> Gen [UTxO' (TxOut CtxUTxO Era)]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
numUTxO ((TxIn, TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton ((TxIn, TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era))
-> Gen (TxIn, TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxIn, TxOut CtxUTxO Era)
forall {ctx}. Gen (TxIn, TxOut ctx)
gen)
where
gen :: Gen (TxIn, TxOut ctx)
gen = (,) (TxIn -> TxOut ctx -> (TxIn, TxOut ctx))
-> Gen TxIn -> Gen (TxOut ctx -> (TxIn, TxOut ctx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary Gen (TxOut ctx -> (TxIn, TxOut ctx))
-> Gen (TxOut ctx) -> Gen (TxIn, TxOut ctx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (TxOut ctx)
forall ctx. Gen (TxOut ctx)
genTxOut
genUTxO1 :: Gen (TxOut CtxUTxO) -> Gen UTxO
genUTxO1 :: Gen (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
genUTxO1 Gen (TxOut CtxUTxO Era)
gen = do
TxIn
txIn <- Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
TxOut CtxUTxO Era
txOut <- Gen (TxOut CtxUTxO Era)
gen
UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era)))
-> UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ (TxIn, TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn
txIn, TxOut CtxUTxO Era
txOut)
genTxOut :: Gen (TxOut ctx)
genTxOut :: forall ctx. Gen (TxOut ctx)
genTxOut =
(TxOut ctx -> TxOut ctx
forall {ctx}. TxOut ctx -> TxOut ctx
noRefScripts (TxOut ctx -> TxOut ctx)
-> (TxOut ctx -> TxOut ctx) -> TxOut ctx -> TxOut ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut ctx -> TxOut ctx
forall {ctx}. TxOut ctx -> TxOut ctx
noStakeRefPtr (TxOut ctx -> TxOut ctx) -> Gen (TxOut ctx) -> Gen (TxOut ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxOut ctx)
gen)
Gen (TxOut ctx) -> (TxOut ctx -> Bool) -> Gen (TxOut ctx)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` TxOut ctx -> Bool
forall {ctx}. TxOut ctx -> Bool
notByronAddress
where
gen :: Gen (TxOut ctx)
gen =
(Value -> Value) -> TxOut ctx -> TxOut ctx
forall era ctx.
(IsMaryEraOnwards era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> (Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
10_000_000))
(TxOut ctx -> TxOut ctx) -> Gen (TxOut ctx) -> Gen (TxOut ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen (TxOut ctx)] -> Gen (TxOut ctx)
forall a. [Gen a] -> Gen a
oneof
[ TxOut (ShelleyLedgerEra Era) -> TxOut ctx
BabbageTxOut (BabbageEra StandardCrypto) -> TxOut ctx
forall ctx. TxOut (ShelleyLedgerEra Era) -> TxOut ctx Era
fromLedgerTxOut (BabbageTxOut (BabbageEra StandardCrypto) -> TxOut ctx)
-> Gen (BabbageTxOut (BabbageEra StandardCrypto))
-> Gen (TxOut ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (BabbageTxOut (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
, TxOut ctx -> TxOut ctx
forall {ctx}. TxOut ctx -> TxOut ctx
notMultiAsset (TxOut ctx -> TxOut ctx)
-> (BabbageTxOut (BabbageEra StandardCrypto) -> TxOut ctx)
-> BabbageTxOut (BabbageEra StandardCrypto)
-> TxOut ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut (ShelleyLedgerEra Era) -> TxOut ctx
BabbageTxOut (BabbageEra StandardCrypto) -> TxOut ctx
forall ctx. TxOut (ShelleyLedgerEra Era) -> TxOut ctx Era
fromLedgerTxOut (BabbageTxOut (BabbageEra StandardCrypto) -> TxOut ctx)
-> Gen (BabbageTxOut (BabbageEra StandardCrypto))
-> Gen (TxOut ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (BabbageTxOut (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
]
notMultiAsset :: TxOut ctx Era -> TxOut ctx Era
notMultiAsset =
(Value -> Value) -> TxOut ctx Era -> TxOut ctx Era
forall era ctx.
(IsMaryEraOnwards era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Coin -> Value
lovelaceToValue (Coin -> Value) -> (Value -> Coin) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Coin
selectLovelace)
notByronAddress :: TxOut ctx -> Bool
notByronAddress (TxOut AddressInEra
addr Value
_ TxOutDatum ctx
_ ReferenceScript
_) = case AddressInEra
addr of
ByronAddressInEra{} -> Bool
False
AddressInEra
_ -> Bool
True
noStakeRefPtr :: TxOut ctx -> TxOut ctx
noStakeRefPtr out :: TxOut ctx
out@(TxOut AddressInEra
addr Value
val TxOutDatum ctx
dat ReferenceScript
refScript) = case AddressInEra
addr of
ShelleyAddressInEra (ShelleyAddress Network
_ PaymentCredential StandardCrypto
cre StakeReference StandardCrypto
sr) ->
case StakeReference StandardCrypto
sr of
Ledger.StakeRefPtr Ptr
_ ->
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut (Address ShelleyAddr -> AddressInEra
ShelleyAddressInEra (Network
-> PaymentCredential StandardCrypto
-> StakeReference StandardCrypto
-> Address ShelleyAddr
ShelleyAddress Network
Ledger.Testnet PaymentCredential StandardCrypto
cre StakeReference StandardCrypto
forall c. StakeReference c
Ledger.StakeRefNull)) Value
val TxOutDatum ctx
dat ReferenceScript
refScript
StakeReference StandardCrypto
_ ->
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut (Address ShelleyAddr -> AddressInEra
ShelleyAddressInEra (Network
-> PaymentCredential StandardCrypto
-> StakeReference StandardCrypto
-> Address ShelleyAddr
ShelleyAddress Network
Ledger.Testnet PaymentCredential StandardCrypto
cre StakeReference StandardCrypto
sr)) Value
val TxOutDatum ctx
dat ReferenceScript
refScript
AddressInEra
_ -> TxOut ctx
out
noRefScripts :: TxOut ctx -> TxOut ctx
noRefScripts TxOut ctx
out =
TxOut ctx
out{txOutReferenceScript = ReferenceScriptNone}
genTxOutByron :: Gen (TxOut ctx)
genTxOutByron :: forall ctx. Gen (TxOut ctx)
genTxOutByron = do
AddressInEra
addr <- Address ByronAddr -> AddressInEra
ByronAddressInEra (Address ByronAddr -> AddressInEra)
-> Gen (Address ByronAddr) -> Gen AddressInEra
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Address ByronAddr)
forall a. Arbitrary a => Gen a
arbitrary
Value
value <- Gen Value
genValue
TxOut ctx -> Gen (TxOut ctx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut ctx -> Gen (TxOut ctx)) -> TxOut ctx -> Gen (TxOut ctx)
forall a b. (a -> b) -> a -> b
$ AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
addr Value
value TxOutDatum ctx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
genTxOutWithReferenceScript :: Gen (TxOut ctx)
genTxOutWithReferenceScript :: forall ctx. Gen (TxOut ctx)
genTxOutWithReferenceScript = do
ReferenceScript
refScript <- (TxOut Any -> ReferenceScript
forall ctx. TxOut ctx -> ReferenceScript
txOutReferenceScript (TxOut Any -> ReferenceScript)
-> (BabbageTxOut (BabbageEra StandardCrypto) -> TxOut Any)
-> BabbageTxOut (BabbageEra StandardCrypto)
-> ReferenceScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut (ShelleyLedgerEra Era) -> TxOut Any
BabbageTxOut (BabbageEra StandardCrypto) -> TxOut Any
forall ctx. TxOut (ShelleyLedgerEra Era) -> TxOut ctx Era
fromLedgerTxOut (BabbageTxOut (BabbageEra StandardCrypto) -> ReferenceScript)
-> Gen (BabbageTxOut (BabbageEra StandardCrypto))
-> Gen ReferenceScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (BabbageTxOut (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary) Gen ReferenceScript
-> (ReferenceScript -> Bool) -> Gen ReferenceScript
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (ReferenceScript -> ReferenceScript -> Bool
forall a. Eq a => a -> a -> Bool
/= ReferenceScript
ReferenceScriptNone)
Gen (TxOut ctx)
forall ctx. Gen (TxOut ctx)
genTxOut Gen (TxOut ctx) -> (TxOut ctx -> TxOut ctx) -> Gen (TxOut ctx)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \TxOut ctx
out -> TxOut ctx
out{txOutReferenceScript = refScript}
genUTxOFor :: VerificationKey PaymentKey -> Gen UTxO
genUTxOFor :: VerificationKey PaymentKey -> Gen (UTxO' (TxOut CtxUTxO Era))
genUTxOFor VerificationKey PaymentKey
vk = do
Int
n <- Gen Int
forall a. Arbitrary a => Gen a
arbitrary Gen Int -> (Int -> Bool) -> Gen Int
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
[TxIn]
inps <- Int -> Gen TxIn -> Gen [TxIn]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
[TxOut CtxUTxO Era]
outs <- Int -> Gen (TxOut CtxUTxO Era) -> Gen [TxOut CtxUTxO Era]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n (VerificationKey PaymentKey -> Gen (TxOut CtxUTxO Era)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutput VerificationKey PaymentKey
vk)
UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era)))
-> UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era))
-> Map TxIn (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ [TxIn] -> [TxOut CtxUTxO Era] -> [(TxIn, TxOut CtxUTxO Era)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxIn]
inps [TxOut CtxUTxO Era]
outs
genOneUTxOFor :: VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor :: VerificationKey PaymentKey -> Gen (UTxO' (TxOut CtxUTxO Era))
genOneUTxOFor VerificationKey PaymentKey
vk = do
TxIn
input <- Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
TxOut CtxUTxO Era
output <- (Int -> Int) -> Gen (TxOut CtxUTxO Era) -> Gen (TxOut CtxUTxO Era)
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a b. a -> b -> a
const Int
1) (Gen (TxOut CtxUTxO Era) -> Gen (TxOut CtxUTxO Era))
-> Gen (TxOut CtxUTxO Era) -> Gen (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> Gen (TxOut CtxUTxO Era)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutput VerificationKey PaymentKey
vk
UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era)))
-> UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era))
-> Map TxIn (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ TxIn -> TxOut CtxUTxO Era -> Map TxIn (TxOut CtxUTxO Era)
forall k a. k -> a -> Map k a
Map.singleton TxIn
input TxOut CtxUTxO Era
output
genAddressInEra :: NetworkId -> Gen AddressInEra
genAddressInEra :: NetworkId -> Gen AddressInEra
genAddressInEra NetworkId
networkId =
NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId (VerificationKey PaymentKey -> AddressInEra)
-> Gen (VerificationKey PaymentKey) -> Gen AddressInEra
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VerificationKey PaymentKey)
genVerificationKey
genValue :: Gen Value
genValue :: Gen Value
genValue = (Value -> Value) -> Gen Value -> Gen Value
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
10_000_000) <>) ((Int -> Int) -> Gen Value -> Gen Value
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10) (Gen Value -> Gen Value) -> Gen Value -> Gen Value
forall a b. (a -> b) -> a -> b
$ MaryValue StandardCrypto -> Value
fromLedgerValue (MaryValue StandardCrypto -> Value)
-> Gen (MaryValue StandardCrypto) -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (MaryValue StandardCrypto)
forall a. Arbitrary a => Gen a
arbitrary)
genAdaOnlyUTxO :: Gen UTxO
genAdaOnlyUTxO :: Gen (UTxO' (TxOut CtxUTxO Era))
genAdaOnlyUTxO = (TxOut CtxUTxO Era -> TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a b. (a -> b) -> UTxO' a -> UTxO' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut CtxUTxO Era -> TxOut CtxUTxO Era
adaOnly (UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era))
-> Gen (UTxO' (TxOut CtxUTxO Era))
-> Gen (UTxO' (TxOut CtxUTxO Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (UTxO' (TxOut CtxUTxO Era))
forall a. Arbitrary a => Gen a
arbitrary
adaOnly :: TxOut CtxUTxO -> TxOut CtxUTxO
adaOnly :: TxOut CtxUTxO Era -> TxOut CtxUTxO Era
adaOnly = \case
TxOut AddressInEra
addr Value
value TxOutDatum CtxUTxO
datum ReferenceScript
refScript ->
AddressInEra
-> Value
-> TxOutDatum CtxUTxO
-> ReferenceScript
-> TxOut CtxUTxO Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
addr (Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Coin
selectLovelace Value
value) TxOutDatum CtxUTxO
datum ReferenceScript
refScript
genUTxOWithSimplifiedAddresses :: Gen UTxO
genUTxOWithSimplifiedAddresses :: Gen (UTxO' (TxOut CtxUTxO Era))
genUTxOWithSimplifiedAddresses =
[(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era)
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs ([(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era))
-> Gen [(TxIn, TxOut CtxUTxO Era)]
-> Gen (UTxO' (TxOut CtxUTxO Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxIn, TxOut CtxUTxO Era) -> Gen [(TxIn, TxOut CtxUTxO Era)]
forall a. Gen a -> Gen [a]
listOf Gen (TxIn, TxOut CtxUTxO Era)
forall {ctx}. Gen (TxIn, TxOut ctx)
genEntry
where
genEntry :: Gen (TxIn, TxOut ctx)
genEntry = (,) (TxIn -> TxOut ctx -> (TxIn, TxOut ctx))
-> Gen TxIn -> Gen (TxOut ctx -> (TxIn, TxOut ctx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn Gen (TxOut ctx -> (TxIn, TxOut ctx))
-> Gen (TxOut ctx) -> Gen (TxIn, TxOut ctx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (TxOut ctx)
forall ctx. Gen (TxOut ctx)
genTxOut
shrinkUTxO :: UTxO -> [UTxO]
shrinkUTxO :: UTxO' (TxOut CtxUTxO Era) -> [UTxO' (TxOut CtxUTxO Era)]
shrinkUTxO = ([(TxIn, TxOut CtxUTxO Era)] -> UTxO' (TxOut CtxUTxO Era))
-> (UTxO' (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)])
-> ([(TxIn, TxOut CtxUTxO Era)] -> [[(TxIn, TxOut CtxUTxO Era)]])
-> UTxO' (TxOut CtxUTxO Era)
-> [UTxO' (TxOut CtxUTxO Era)]
forall a b. (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b]
shrinkMapBy (Map TxIn (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era))
-> ([(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)]
-> UTxO' (TxOut CtxUTxO Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
[Item (Map TxIn (TxOut CtxUTxO Era))]
-> Map TxIn (TxOut CtxUTxO Era)
forall l. IsList l => [Item l] -> l
fromList) UTxO' (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs (((TxIn, TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)])
-> [(TxIn, TxOut CtxUTxO Era)] -> [[(TxIn, TxOut CtxUTxO Era)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (TxIn, TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
shrinkOne)
where
shrinkOne :: (TxIn, TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
shrinkOne :: (TxIn, TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
shrinkOne (TxIn
i, TxOut CtxUTxO Era
o) = case TxOut CtxUTxO Era
o of
TxOut AddressInEra
addr Value
value TxOutDatum CtxUTxO
datum ReferenceScript
refScript ->
[ (TxIn
i, AddressInEra
-> Value
-> TxOutDatum CtxUTxO
-> ReferenceScript
-> TxOut CtxUTxO Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
addr Value
value' TxOutDatum CtxUTxO
datum ReferenceScript
refScript)
| Value
value' <- Value -> [Value]
shrinkValue Value
value
]
shrinkValue :: Value -> [Value]
shrinkValue :: Value -> [Value]
shrinkValue =
([(AssetId, Quantity)] -> Value)
-> (Value -> [(AssetId, Quantity)])
-> ([(AssetId, Quantity)] -> [[(AssetId, Quantity)]])
-> Value
-> [Value]
forall a b. (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b]
shrinkMapBy [(AssetId, Quantity)] -> Value
valueFromList Value -> [(AssetId, Quantity)]
valueToList [(AssetId, Quantity)] -> [[(AssetId, Quantity)]]
forall a. [a] -> [[a]]
shrinkListAggressively
instance Arbitrary AssetName where
arbitrary :: Gen AssetName
arbitrary = ByteString -> AssetName
AssetName (ByteString -> AssetName)
-> (ByteString -> ByteString) -> ByteString -> AssetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.take Int
32 (ByteString -> AssetName) -> Gen ByteString -> Gen AssetName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary
instance Arbitrary TxId where
arbitrary :: Gen TxId
arbitrary = TxIn -> TxId
onlyTxId (TxIn -> TxId) -> Gen TxIn -> Gen TxId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
where
onlyTxId :: TxIn -> TxId
onlyTxId (TxIn TxId
txi TxIx
_) = TxId
txi
instance Arbitrary (TxOut CtxUTxO) where
arbitrary :: Gen (TxOut CtxUTxO Era)
arbitrary = Gen (TxOut CtxUTxO Era)
forall ctx. Gen (TxOut ctx)
genTxOut
shrink :: TxOut CtxUTxO Era -> [TxOut CtxUTxO Era]
shrink TxOut CtxUTxO Era
txOut = TxOut (ShelleyLedgerEra Era) -> TxOut CtxUTxO Era
BabbageTxOut (BabbageEra StandardCrypto) -> TxOut CtxUTxO Era
forall ctx. TxOut (ShelleyLedgerEra Era) -> TxOut ctx Era
fromLedgerTxOut (BabbageTxOut (BabbageEra StandardCrypto) -> TxOut CtxUTxO Era)
-> [BabbageTxOut (BabbageEra StandardCrypto)]
-> [TxOut CtxUTxO Era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BabbageTxOut (BabbageEra StandardCrypto)
-> [BabbageTxOut (BabbageEra StandardCrypto)]
forall a. Arbitrary a => a -> [a]
shrink (TxOut CtxUTxO Era -> TxOut (ShelleyLedgerEra Era)
toLedgerTxOut TxOut CtxUTxO Era
txOut)
instance Arbitrary (VerificationKey PaymentKey) where
arbitrary :: Gen (VerificationKey PaymentKey)
arbitrary = (VerificationKey PaymentKey, SigningKey PaymentKey)
-> VerificationKey PaymentKey
forall a b. (a, b) -> a
fst ((VerificationKey PaymentKey, SigningKey PaymentKey)
-> VerificationKey PaymentKey)
-> Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> Gen (VerificationKey PaymentKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
instance Arbitrary (Hash PaymentKey) where
arbitrary :: Gen (Hash PaymentKey)
arbitrary = HasCallStack => ByteString -> Hash PaymentKey
ByteString -> Hash PaymentKey
unsafePaymentKeyHashFromBytes (ByteString -> Hash PaymentKey)
-> ([Word8] -> ByteString) -> [Word8] -> Hash PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> Hash PaymentKey)
-> Gen [Word8] -> Gen (Hash PaymentKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
28 Gen Word8
forall a. Arbitrary a => Gen a
arbitrary
instance ToCBOR UTxO where
toCBOR :: UTxO' (TxOut CtxUTxO Era) -> Encoding
toCBOR = UTxO (BabbageEra StandardCrypto) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (UTxO (BabbageEra StandardCrypto) -> Encoding)
-> (UTxO' (TxOut CtxUTxO Era) -> UTxO (BabbageEra StandardCrypto))
-> UTxO' (TxOut CtxUTxO Era)
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO' (TxOut CtxUTxO Era) -> UTxO (ShelleyLedgerEra Era)
UTxO' (TxOut CtxUTxO Era) -> UTxO (BabbageEra StandardCrypto)
toLedgerUTxO
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (UTxO' (TxOut CtxUTxO Era)) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
sz Proxy (UTxO' (TxOut CtxUTxO Era))
_ = (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (UTxO (BabbageEra StandardCrypto)) -> Size
forall a.
ToCBOR a =>
(forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size
encodedSizeExpr Proxy t -> Size
forall t. ToCBOR t => Proxy t -> Size
sz (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Ledger.UTxO LedgerEra))
instance FromCBOR UTxO where
fromCBOR :: forall s. Decoder s (UTxO' (TxOut CtxUTxO Era))
fromCBOR = UTxO (ShelleyLedgerEra Era) -> UTxO' (TxOut CtxUTxO Era)
UTxO (BabbageEra StandardCrypto) -> UTxO' (TxOut CtxUTxO Era)
fromLedgerUTxO (UTxO (BabbageEra StandardCrypto) -> UTxO' (TxOut CtxUTxO Era))
-> Decoder s (UTxO (BabbageEra StandardCrypto))
-> Decoder s (UTxO' (TxOut CtxUTxO Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (UTxO (BabbageEra StandardCrypto))
forall s. Decoder s (UTxO (BabbageEra StandardCrypto))
forall a s. FromCBOR a => Decoder s a
fromCBOR
label :: Proxy (UTxO' (TxOut CtxUTxO Era)) -> Text
label Proxy (UTxO' (TxOut CtxUTxO Era))
_ = Proxy (UTxO (BabbageEra StandardCrypto)) -> Text
forall a. FromCBOR a => Proxy a -> Text
label (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Ledger.UTxO LedgerEra))
instance Arbitrary UTxO where
shrink :: UTxO' (TxOut CtxUTxO Era) -> [UTxO' (TxOut CtxUTxO Era)]
shrink = UTxO' (TxOut CtxUTxO Era) -> [UTxO' (TxOut CtxUTxO Era)]
shrinkUTxO
arbitrary :: Gen (UTxO' (TxOut CtxUTxO Era))
arbitrary = Gen (UTxO' (TxOut CtxUTxO Era))
genUTxOAlonzo