module Hydra.Chain.Direct.ScriptRegistry where
import Hydra.Prelude
import Cardano.Api.UTxO (UTxO)
import Cardano.Api.UTxO qualified as UTxO
import Data.Map qualified as Map
import Hydra.Cardano.Api (
CtxUTxO,
Key (..),
NetworkId,
PaymentKey,
ScriptHash,
ShelleyWitnessSigningKey (WitnessPaymentKey),
SigningKey,
SocketPath,
TxId,
TxIn (..),
TxIx (..),
TxOut,
WitCtx (..),
examplePlutusScriptAlwaysFails,
getTxId,
hashScriptInAnyLang,
makeShelleyKeyWitness,
makeSignedTransaction,
mkScriptAddress,
mkScriptRef,
mkTxOutAutoBalance,
mkVkAddress,
selectLovelace,
throwErrorAsException,
txOutReferenceScript,
txOutValue,
pattern ReferenceScript,
pattern ReferenceScriptNone,
pattern TxOutDatumNone,
)
import Hydra.Chain.CardanoClient (
QueryPoint (..),
awaitTransaction,
buildTransaction,
queryProtocolParameters,
queryUTxOByTxIn,
queryUTxOFor,
submitTransaction,
)
import Hydra.Contract (ScriptInfo (..), scriptInfo)
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.Initial qualified as Initial
import Hydra.Ledger.Cardano (genTxOutAdaOnly)
data ScriptRegistry = ScriptRegistry
{ ScriptRegistry -> (TxIn, TxOut CtxUTxO)
initialReference :: (TxIn, TxOut CtxUTxO)
, ScriptRegistry -> (TxIn, TxOut CtxUTxO)
commitReference :: (TxIn, TxOut CtxUTxO)
, ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference :: (TxIn, TxOut CtxUTxO)
}
deriving stock (ScriptRegistry -> ScriptRegistry -> Bool
(ScriptRegistry -> ScriptRegistry -> Bool)
-> (ScriptRegistry -> ScriptRegistry -> Bool) -> Eq ScriptRegistry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptRegistry -> ScriptRegistry -> Bool
== :: ScriptRegistry -> ScriptRegistry -> Bool
$c/= :: ScriptRegistry -> ScriptRegistry -> Bool
/= :: ScriptRegistry -> ScriptRegistry -> Bool
Eq, Int -> ScriptRegistry -> ShowS
[ScriptRegistry] -> ShowS
ScriptRegistry -> String
(Int -> ScriptRegistry -> ShowS)
-> (ScriptRegistry -> String)
-> ([ScriptRegistry] -> ShowS)
-> Show ScriptRegistry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptRegistry -> ShowS
showsPrec :: Int -> ScriptRegistry -> ShowS
$cshow :: ScriptRegistry -> String
show :: ScriptRegistry -> String
$cshowList :: [ScriptRegistry] -> ShowS
showList :: [ScriptRegistry] -> ShowS
Show, (forall x. ScriptRegistry -> Rep ScriptRegistry x)
-> (forall x. Rep ScriptRegistry x -> ScriptRegistry)
-> Generic ScriptRegistry
forall x. Rep ScriptRegistry x -> ScriptRegistry
forall x. ScriptRegistry -> Rep ScriptRegistry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScriptRegistry -> Rep ScriptRegistry x
from :: forall x. ScriptRegistry -> Rep ScriptRegistry x
$cto :: forall x. Rep ScriptRegistry x -> ScriptRegistry
to :: forall x. Rep ScriptRegistry x -> ScriptRegistry
Generic)
deriving anyclass ([ScriptRegistry] -> Value
[ScriptRegistry] -> Encoding
ScriptRegistry -> Bool
ScriptRegistry -> Value
ScriptRegistry -> Encoding
(ScriptRegistry -> Value)
-> (ScriptRegistry -> Encoding)
-> ([ScriptRegistry] -> Value)
-> ([ScriptRegistry] -> Encoding)
-> (ScriptRegistry -> Bool)
-> ToJSON ScriptRegistry
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ScriptRegistry -> Value
toJSON :: ScriptRegistry -> Value
$ctoEncoding :: ScriptRegistry -> Encoding
toEncoding :: ScriptRegistry -> Encoding
$ctoJSONList :: [ScriptRegistry] -> Value
toJSONList :: [ScriptRegistry] -> Value
$ctoEncodingList :: [ScriptRegistry] -> Encoding
toEncodingList :: [ScriptRegistry] -> Encoding
$comitField :: ScriptRegistry -> Bool
omitField :: ScriptRegistry -> Bool
ToJSON, Maybe ScriptRegistry
Value -> Parser [ScriptRegistry]
Value -> Parser ScriptRegistry
(Value -> Parser ScriptRegistry)
-> (Value -> Parser [ScriptRegistry])
-> Maybe ScriptRegistry
-> FromJSON ScriptRegistry
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ScriptRegistry
parseJSON :: Value -> Parser ScriptRegistry
$cparseJSONList :: Value -> Parser [ScriptRegistry]
parseJSONList :: Value -> Parser [ScriptRegistry]
$comittedField :: Maybe ScriptRegistry
omittedField :: Maybe ScriptRegistry
FromJSON)
genScriptRegistry :: Gen ScriptRegistry
genScriptRegistry :: Gen ScriptRegistry
genScriptRegistry = do
TxId
txId <- Gen TxId
forall a. Arbitrary a => Gen a
arbitrary
VerificationKey PaymentKey
vk <- Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary
TxOut CtxUTxO
txOut <- VerificationKey PaymentKey -> Gen (TxOut CtxUTxO)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genTxOutAdaOnly VerificationKey PaymentKey
vk
ScriptRegistry -> Gen ScriptRegistry
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptRegistry -> Gen ScriptRegistry)
-> ScriptRegistry -> Gen ScriptRegistry
forall a b. (a -> b) -> a -> b
$
ScriptRegistry
{ $sel:initialReference:ScriptRegistry :: (TxIn, TxOut CtxUTxO)
initialReference =
( TxId -> TxIx -> TxIn
TxIn TxId
txId (Word -> TxIx
TxIx Word
0)
, TxOut CtxUTxO
txOut{txOutReferenceScript = mkScriptRef Initial.validatorScript}
)
, $sel:commitReference:ScriptRegistry :: (TxIn, TxOut CtxUTxO)
commitReference =
( TxId -> TxIx -> TxIn
TxIn TxId
txId (Word -> TxIx
TxIx Word
1)
, TxOut CtxUTxO
txOut{txOutReferenceScript = mkScriptRef Commit.validatorScript}
)
, $sel:headReference:ScriptRegistry :: (TxIn, TxOut CtxUTxO)
headReference =
( TxId -> TxIx -> TxIn
TxIn TxId
txId (Word -> TxIx
TxIx Word
2)
, TxOut CtxUTxO
txOut{txOutReferenceScript = mkScriptRef Head.validatorScript}
)
}
data NewScriptRegistryException = MissingScript
{ NewScriptRegistryException -> Text
scriptName :: Text
, NewScriptRegistryException -> ScriptHash
scriptHash :: ScriptHash
, NewScriptRegistryException -> Set ScriptHash
discoveredScripts :: Set ScriptHash
}
deriving stock (NewScriptRegistryException -> NewScriptRegistryException -> Bool
(NewScriptRegistryException -> NewScriptRegistryException -> Bool)
-> (NewScriptRegistryException
-> NewScriptRegistryException -> Bool)
-> Eq NewScriptRegistryException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NewScriptRegistryException -> NewScriptRegistryException -> Bool
== :: NewScriptRegistryException -> NewScriptRegistryException -> Bool
$c/= :: NewScriptRegistryException -> NewScriptRegistryException -> Bool
/= :: NewScriptRegistryException -> NewScriptRegistryException -> Bool
Eq, Int -> NewScriptRegistryException -> ShowS
[NewScriptRegistryException] -> ShowS
NewScriptRegistryException -> String
(Int -> NewScriptRegistryException -> ShowS)
-> (NewScriptRegistryException -> String)
-> ([NewScriptRegistryException] -> ShowS)
-> Show NewScriptRegistryException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NewScriptRegistryException -> ShowS
showsPrec :: Int -> NewScriptRegistryException -> ShowS
$cshow :: NewScriptRegistryException -> String
show :: NewScriptRegistryException -> String
$cshowList :: [NewScriptRegistryException] -> ShowS
showList :: [NewScriptRegistryException] -> ShowS
Show)
instance Exception NewScriptRegistryException
newScriptRegistry :: UTxO -> Either NewScriptRegistryException ScriptRegistry
newScriptRegistry :: UTxO' (TxOut CtxUTxO)
-> Either NewScriptRegistryException ScriptRegistry
newScriptRegistry =
Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException ScriptRegistry
resolve (Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException ScriptRegistry)
-> (UTxO' (TxOut CtxUTxO) -> Map ScriptHash (TxIn, TxOut CtxUTxO))
-> UTxO' (TxOut CtxUTxO)
-> Either NewScriptRegistryException ScriptRegistry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn -> TxOut CtxUTxO -> Map ScriptHash (TxIn, TxOut CtxUTxO))
-> Map TxIn (TxOut CtxUTxO) -> Map ScriptHash (TxIn, TxOut CtxUTxO)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey TxIn -> TxOut CtxUTxO -> Map ScriptHash (TxIn, TxOut CtxUTxO)
collect (Map TxIn (TxOut CtxUTxO) -> Map ScriptHash (TxIn, TxOut CtxUTxO))
-> (UTxO' (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO))
-> UTxO' (TxOut CtxUTxO)
-> Map ScriptHash (TxIn, TxOut CtxUTxO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO' (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap
where
collect ::
TxIn ->
TxOut CtxUTxO ->
Map ScriptHash (TxIn, TxOut CtxUTxO)
collect :: TxIn -> TxOut CtxUTxO -> Map ScriptHash (TxIn, TxOut CtxUTxO)
collect TxIn
i TxOut CtxUTxO
o =
case TxOut CtxUTxO -> ReferenceScript Era
forall ctx. TxOut ctx -> ReferenceScript Era
txOutReferenceScript TxOut CtxUTxO
o of
ReferenceScript Era
ReferenceScriptNone -> Map ScriptHash (TxIn, TxOut CtxUTxO)
forall a. Monoid a => a
mempty
ReferenceScript ScriptInAnyLang
script -> ScriptHash
-> (TxIn, TxOut CtxUTxO) -> Map ScriptHash (TxIn, TxOut CtxUTxO)
forall k a. k -> a -> Map k a
Map.singleton (ScriptInAnyLang -> ScriptHash
hashScriptInAnyLang ScriptInAnyLang
script) (TxIn
i, TxOut CtxUTxO
o)
resolve ::
Map ScriptHash (TxIn, TxOut CtxUTxO) ->
Either NewScriptRegistryException ScriptRegistry
resolve :: Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException ScriptRegistry
resolve Map ScriptHash (TxIn, TxOut CtxUTxO)
m = do
(TxIn, TxOut CtxUTxO)
initialReference <- Text
-> ScriptHash
-> Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException (TxIn, TxOut CtxUTxO)
forall {b}.
Text
-> ScriptHash
-> Map ScriptHash b
-> Either NewScriptRegistryException b
lookupScriptHash Text
"νInitial" ScriptHash
initialScriptHash Map ScriptHash (TxIn, TxOut CtxUTxO)
m
(TxIn, TxOut CtxUTxO)
commitReference <- Text
-> ScriptHash
-> Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException (TxIn, TxOut CtxUTxO)
forall {b}.
Text
-> ScriptHash
-> Map ScriptHash b
-> Either NewScriptRegistryException b
lookupScriptHash Text
"νCommit" ScriptHash
commitScriptHash Map ScriptHash (TxIn, TxOut CtxUTxO)
m
(TxIn, TxOut CtxUTxO)
headReference <- Text
-> ScriptHash
-> Map ScriptHash (TxIn, TxOut CtxUTxO)
-> Either NewScriptRegistryException (TxIn, TxOut CtxUTxO)
forall {b}.
Text
-> ScriptHash
-> Map ScriptHash b
-> Either NewScriptRegistryException b
lookupScriptHash Text
"νHead" ScriptHash
headScriptHash Map ScriptHash (TxIn, TxOut CtxUTxO)
m
ScriptRegistry -> Either NewScriptRegistryException ScriptRegistry
forall a. a -> Either NewScriptRegistryException a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptRegistry
-> Either NewScriptRegistryException ScriptRegistry)
-> ScriptRegistry
-> Either NewScriptRegistryException ScriptRegistry
forall a b. (a -> b) -> a -> b
$ ScriptRegistry{(TxIn, TxOut CtxUTxO)
$sel:initialReference:ScriptRegistry :: (TxIn, TxOut CtxUTxO)
initialReference :: (TxIn, TxOut CtxUTxO)
initialReference, (TxIn, TxOut CtxUTxO)
$sel:commitReference:ScriptRegistry :: (TxIn, TxOut CtxUTxO)
commitReference :: (TxIn, TxOut CtxUTxO)
commitReference, (TxIn, TxOut CtxUTxO)
$sel:headReference:ScriptRegistry :: (TxIn, TxOut CtxUTxO)
headReference :: (TxIn, TxOut CtxUTxO)
headReference}
lookupScriptHash :: Text
-> ScriptHash
-> Map ScriptHash b
-> Either NewScriptRegistryException b
lookupScriptHash Text
name ScriptHash
sh Map ScriptHash b
m =
case Key (Map ScriptHash b)
-> Map ScriptHash b -> Maybe (Val (Map ScriptHash b))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup Key (Map ScriptHash b)
ScriptHash
sh Map ScriptHash b
m of
Maybe (Val (Map ScriptHash b))
Nothing -> NewScriptRegistryException -> Either NewScriptRegistryException b
forall a b. a -> Either a b
Left (NewScriptRegistryException -> Either NewScriptRegistryException b)
-> NewScriptRegistryException
-> Either NewScriptRegistryException b
forall a b. (a -> b) -> a -> b
$ Text -> ScriptHash -> Set ScriptHash -> NewScriptRegistryException
MissingScript Text
name ScriptHash
sh (Map ScriptHash b -> Set ScriptHash
forall k a. Map k a -> Set k
Map.keysSet Map ScriptHash b
m)
Just Val (Map ScriptHash b)
s -> b -> Either NewScriptRegistryException b
forall a b. b -> Either a b
Right b
Val (Map ScriptHash b)
s
ScriptInfo
{ ScriptHash
initialScriptHash :: ScriptHash
initialScriptHash :: ScriptInfo -> ScriptHash
initialScriptHash
, ScriptHash
commitScriptHash :: ScriptHash
commitScriptHash :: ScriptInfo -> ScriptHash
commitScriptHash
, ScriptHash
headScriptHash :: ScriptHash
headScriptHash :: ScriptInfo -> ScriptHash
headScriptHash
} = ScriptInfo
scriptInfo
registryUTxO :: ScriptRegistry -> UTxO
registryUTxO :: ScriptRegistry -> UTxO' (TxOut CtxUTxO)
registryUTxO ScriptRegistry
scriptRegistry =
[(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO)
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs [(TxIn, TxOut CtxUTxO)
initialReference, (TxIn, TxOut CtxUTxO)
commitReference, (TxIn, TxOut CtxUTxO)
headReference]
where
ScriptRegistry
{ (TxIn, TxOut CtxUTxO)
$sel:initialReference:ScriptRegistry :: ScriptRegistry -> (TxIn, TxOut CtxUTxO)
initialReference :: (TxIn, TxOut CtxUTxO)
initialReference
, (TxIn, TxOut CtxUTxO)
$sel:commitReference:ScriptRegistry :: ScriptRegistry -> (TxIn, TxOut CtxUTxO)
commitReference :: (TxIn, TxOut CtxUTxO)
commitReference
, (TxIn, TxOut CtxUTxO)
$sel:headReference:ScriptRegistry :: ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference :: (TxIn, TxOut CtxUTxO)
headReference
} = ScriptRegistry
scriptRegistry
queryScriptRegistry ::
(MonadIO m, MonadThrow m) =>
NetworkId ->
SocketPath ->
TxId ->
m ScriptRegistry
queryScriptRegistry :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
NetworkId -> SocketPath -> TxId -> m ScriptRegistry
queryScriptRegistry NetworkId
networkId SocketPath
socketPath TxId
txId = do
UTxO' (TxOut CtxUTxO)
utxo <- IO (UTxO' (TxOut CtxUTxO)) -> m (UTxO' (TxOut CtxUTxO))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTxO' (TxOut CtxUTxO)) -> m (UTxO' (TxOut CtxUTxO)))
-> IO (UTxO' (TxOut CtxUTxO)) -> m (UTxO' (TxOut CtxUTxO))
forall a b. (a -> b) -> a -> b
$ NetworkId
-> SocketPath -> QueryPoint -> [TxIn] -> IO (UTxO' (TxOut CtxUTxO))
queryUTxOByTxIn NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip [TxIn]
candidates
case UTxO' (TxOut CtxUTxO)
-> Either NewScriptRegistryException ScriptRegistry
newScriptRegistry UTxO' (TxOut CtxUTxO)
utxo of
Left NewScriptRegistryException
e -> NewScriptRegistryException -> m ScriptRegistry
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO NewScriptRegistryException
e
Right ScriptRegistry
sr -> ScriptRegistry -> m ScriptRegistry
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptRegistry
sr
where
candidates :: [TxIn]
candidates = [TxId -> TxIx -> TxIn
TxIn TxId
txId TxIx
ix | TxIx
ix <- [Word -> TxIx
TxIx Word
0 .. Word -> TxIx
TxIx Word
10]]
publishHydraScripts ::
NetworkId ->
SocketPath ->
SigningKey PaymentKey ->
IO TxId
publishHydraScripts :: NetworkId -> SocketPath -> SigningKey PaymentKey -> IO TxId
publishHydraScripts NetworkId
networkId SocketPath
socketPath SigningKey PaymentKey
sk = do
PParams StandardBabbage
pparams <- NetworkId -> SocketPath -> QueryPoint -> IO (PParams LedgerEra)
queryProtocolParameters NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip
UTxO' (TxOut CtxUTxO)
utxo <- NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO))
queryUTxOFor NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip VerificationKey PaymentKey
vk
let outputs :: [TxOut CtxTx Era]
outputs =
PParams StandardBabbage -> SerialisedScript -> TxOut CtxTx Era
mkScriptTxOut PParams StandardBabbage
pparams
(SerialisedScript -> TxOut CtxTx Era)
-> [SerialisedScript] -> [TxOut CtxTx Era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ SerialisedScript
Initial.validatorScript
, SerialisedScript
Commit.validatorScript
, SerialisedScript
Head.validatorScript
]
totalDeposit :: Coin
totalDeposit = [Coin] -> Coin
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum (Value -> Coin
selectLovelace (Value -> Coin)
-> (TxOut CtxTx Era -> Value) -> TxOut CtxTx Era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue (TxOut CtxTx Era -> Coin) -> [TxOut CtxTx Era] -> [Coin]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOut CtxTx Era]
outputs)
someUTxO :: UTxO' (TxOut CtxUTxO)
someUTxO =
UTxO' (TxOut CtxUTxO)
-> ((TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO))
-> Maybe (TxIn, TxOut CtxUTxO)
-> UTxO' (TxOut CtxUTxO)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTxO' (TxOut CtxUTxO)
forall a. Monoid a => a
mempty (TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (Maybe (TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO))
-> Maybe (TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$
(TxOut CtxUTxO -> Bool)
-> UTxO' (TxOut CtxUTxO) -> Maybe (TxIn, TxOut CtxUTxO)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (\TxOut CtxUTxO
o -> Value -> Coin
selectLovelace (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
o) Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
totalDeposit) UTxO' (TxOut CtxUTxO)
utxo
NetworkId
-> SocketPath
-> AddressInEra
-> UTxO' (TxOut CtxUTxO)
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) TxBody)
buildTransaction
NetworkId
networkId
SocketPath
socketPath
AddressInEra
changeAddress
UTxO' (TxOut CtxUTxO)
someUTxO
[]
[TxOut CtxTx Era]
outputs
IO (Either (TxBodyErrorAutoBalance Era) TxBody)
-> (Either (TxBodyErrorAutoBalance Era) TxBody -> IO TxId)
-> IO TxId
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left TxBodyErrorAutoBalance Era
e ->
TxBodyErrorAutoBalance Era -> IO TxId
forall e a. Error e => e -> IO a
throwErrorAsException TxBodyErrorAutoBalance Era
e
Right TxBody
body -> do
let tx :: Tx Era
tx = [KeyWitness Era] -> TxBody -> Tx Era
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [TxBody -> ShelleyWitnessSigningKey -> KeyWitness Era
makeShelleyKeyWitness TxBody
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
sk)] TxBody
body
NetworkId -> SocketPath -> Tx Era -> IO ()
submitTransaction NetworkId
networkId SocketPath
socketPath Tx Era
tx
IO (UTxO' (TxOut CtxUTxO)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (UTxO' (TxOut CtxUTxO)) -> IO ())
-> IO (UTxO' (TxOut CtxUTxO)) -> IO ()
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> Tx Era -> IO (UTxO' (TxOut CtxUTxO))
awaitTransaction NetworkId
networkId SocketPath
socketPath Tx Era
tx
TxId -> IO TxId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxId -> IO TxId) -> TxId -> IO TxId
forall a b. (a -> b) -> a -> b
$ TxBody -> TxId
forall era. TxBody era -> TxId
getTxId TxBody
body
where
vk :: VerificationKey PaymentKey
vk = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk
changeAddress :: AddressInEra
changeAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
vk
mkScriptTxOut :: PParams StandardBabbage -> SerialisedScript -> TxOut CtxTx Era
mkScriptTxOut PParams StandardBabbage
pparams SerialisedScript
script =
PParams LedgerEra
-> AddressInEra
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
mkTxOutAutoBalance
PParams LedgerEra
PParams StandardBabbage
pparams
AddressInEra
unspendableScriptAddress
Value
forall a. Monoid a => a
mempty
TxOutDatum CtxTx Era
forall ctx. TxOutDatum ctx
TxOutDatumNone
(SerialisedScript -> ReferenceScript Era
mkScriptRef SerialisedScript
script)
unspendableScriptAddress :: AddressInEra
unspendableScriptAddress =
NetworkId -> PlutusScript PlutusScriptV1 -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId (PlutusScript PlutusScriptV1 -> AddressInEra)
-> PlutusScript PlutusScriptV1 -> AddressInEra
forall a b. (a -> b) -> a -> b
$ WitCtx WitCtxTxIn -> PlutusScript PlutusScriptV1
forall witctx. WitCtx witctx -> PlutusScript PlutusScriptV1
examplePlutusScriptAlwaysFails WitCtx WitCtxTxIn
WitCtxTxIn