-- | A data-type to keep track of reference Hydra scripts published on-chain,
-- and needed to construct transactions leveraging reference inputs.
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)

-- | Hydra scripts published as reference scripts at these UTxO.
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

-- | Create a script registry from a UTxO containing outputs with reference
-- scripts. This will return 'Nothing' if one or all of the references could not
-- be found.
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

-- | Get the UTxO that corresponds to a script registry.
--
-- **Property**:
--
--     newScriptRegistry (registryUTxO r) === Just r
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

-- | Query for 'TxIn's in the search for outputs containing all the reference
-- scripts of the 'ScriptRegistry'.
--
-- This is implemented by repeated querying until we have all necessary
-- reference scripts as we do only know the transaction id, not the indices.
--
-- NOTE: This is limited to an upper bound of 10 to not query too much before
-- providing an error.
--
-- NOTE: If this should change, make sure to update the command line help.
--
-- Can throw at least 'NewScriptRegistryException' on failure.
queryScriptRegistry ::
  (MonadIO m, MonadThrow m) =>
  -- | cardano-node's network identifier.
  -- A combination of network discriminant + magic number.
  NetworkId ->
  -- | Filepath to the cardano-node's domain socket
  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]] -- Arbitrary but, high-enough.

publishHydraScripts ::
  -- | Expected network discriminant.
  NetworkId ->
  -- | Path to the cardano-node's domain socket
  SocketPath ->
  -- | Keys assumed to hold funds to pay for the publishing transaction.
  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