{-# LANGUAGE DuplicateRecordFields #-}
module Hydra.Tx.Close where
import Hydra.Cardano.Api
import Hydra.Prelude
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Data.ContestationPeriod (addContestationPeriod)
import Hydra.Data.ContestationPeriod qualified as OnChain
import Hydra.Data.Party qualified as OnChain
import Hydra.Ledger.Cardano.Builder (
unsafeBuildTransaction,
)
import Hydra.Plutus.Extras.Time (posixFromUTCTime)
import Hydra.Tx (
ConfirmedSnapshot (..),
HeadId,
ScriptRegistry (headReference),
Snapshot (..),
SnapshotVersion,
getSnapshot,
hashUTxO,
headIdToCurrencySymbol,
headReference,
)
import Hydra.Tx.Contest (PointInTime)
import Hydra.Tx.Crypto (toPlutusSignatures)
import Hydra.Tx.Utils (IncrementalAction (..), mkHydraHeadV1TxName)
import PlutusLedgerApi.V3 (toBuiltin)
data OpenThreadOutput = OpenThreadOutput
{ OpenThreadOutput -> (TxIn, TxOut CtxUTxO)
openThreadUTxO :: (TxIn, TxOut CtxUTxO)
, OpenThreadOutput -> ContestationPeriod
openContestationPeriod :: OnChain.ContestationPeriod
, OpenThreadOutput -> [Party]
openParties :: [OnChain.Party]
}
deriving stock (OpenThreadOutput -> OpenThreadOutput -> Bool
(OpenThreadOutput -> OpenThreadOutput -> Bool)
-> (OpenThreadOutput -> OpenThreadOutput -> Bool)
-> Eq OpenThreadOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpenThreadOutput -> OpenThreadOutput -> Bool
== :: OpenThreadOutput -> OpenThreadOutput -> Bool
$c/= :: OpenThreadOutput -> OpenThreadOutput -> Bool
/= :: OpenThreadOutput -> OpenThreadOutput -> Bool
Eq, Int -> OpenThreadOutput -> ShowS
[OpenThreadOutput] -> ShowS
OpenThreadOutput -> String
(Int -> OpenThreadOutput -> ShowS)
-> (OpenThreadOutput -> String)
-> ([OpenThreadOutput] -> ShowS)
-> Show OpenThreadOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenThreadOutput -> ShowS
showsPrec :: Int -> OpenThreadOutput -> ShowS
$cshow :: OpenThreadOutput -> String
show :: OpenThreadOutput -> String
$cshowList :: [OpenThreadOutput] -> ShowS
showList :: [OpenThreadOutput] -> ShowS
Show, (forall x. OpenThreadOutput -> Rep OpenThreadOutput x)
-> (forall x. Rep OpenThreadOutput x -> OpenThreadOutput)
-> Generic OpenThreadOutput
forall x. Rep OpenThreadOutput x -> OpenThreadOutput
forall x. OpenThreadOutput -> Rep OpenThreadOutput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OpenThreadOutput -> Rep OpenThreadOutput x
from :: forall x. OpenThreadOutput -> Rep OpenThreadOutput x
$cto :: forall x. Rep OpenThreadOutput x -> OpenThreadOutput
to :: forall x. Rep OpenThreadOutput x -> OpenThreadOutput
Generic)
closeTx ::
ScriptRegistry ->
VerificationKey PaymentKey ->
HeadId ->
SnapshotVersion ->
ConfirmedSnapshot Tx ->
SlotNo ->
PointInTime ->
OpenThreadOutput ->
IncrementalAction ->
Tx
closeTx :: ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> OpenThreadOutput
-> IncrementalAction
-> Tx
closeTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk HeadId
headId SnapshotVersion
openVersion ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
startSlotNo (SlotNo
endSlotNo, UTCTime
utcTime) OpenThreadOutput
openThreadOutput IncrementalAction
incrementalAction =
HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
TxBodyContent BuildTx
defaultTxBodyContent
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns [(TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness)]
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
IsBabbageBasedEra era =>
[TxIn] -> TxBodyContent build era -> TxBodyContent build era
addTxInsReference [TxIn
headScriptRef]
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx Era] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
addTxOuts [TxOut CtxTx Era
headOutputAfter]
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
IsAlonzoBasedEra era =>
[Hash PaymentKey]
-> TxBodyContent build era -> TxBodyContent build era
addTxExtraKeyWits [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk]
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxValidityLowerBound Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxValidityLowerBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityLowerBound (SlotNo -> TxValidityLowerBound Era
TxValidityLowerBound SlotNo
startSlotNo)
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxValidityUpperBound Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxValidityUpperBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityUpperBound (SlotNo -> TxValidityUpperBound Era
TxValidityUpperBound SlotNo
endSlotNo)
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra Era
TxMetadataInEra (TxMetadata -> TxMetadataInEra Era)
-> TxMetadata -> TxMetadataInEra Era
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"CloseTx")
where
OpenThreadOutput
{ $sel:openThreadUTxO:OpenThreadOutput :: OpenThreadOutput -> (TxIn, TxOut CtxUTxO)
openThreadUTxO = (TxIn
headInput, TxOut CtxUTxO
headOutputBefore)
, ContestationPeriod
$sel:openContestationPeriod:OpenThreadOutput :: OpenThreadOutput -> ContestationPeriod
openContestationPeriod :: ContestationPeriod
openContestationPeriod
, [Party]
$sel:openParties:OpenThreadOutput :: OpenThreadOutput -> [Party]
openParties :: [Party]
openParties
} = OpenThreadOutput
openThreadOutput
headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness =
Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
TxIn
-> PlutusScript PlutusScriptV3
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript PlutusScriptV3
Head.validatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer
headScriptRef :: TxIn
headScriptRef =
(TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
headRedeemer :: ScriptRedeemer
headRedeemer = Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (Input -> ScriptRedeemer) -> Input -> ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ CloseRedeemer -> Input
Head.Close CloseRedeemer
closeRedeemer
closeRedeemer :: CloseRedeemer
closeRedeemer =
case ConfirmedSnapshot Tx
confirmedSnapshot of
InitialSnapshot{} -> CloseRedeemer
Head.CloseInitial
ConfirmedSnapshot{MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures, $sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version}} ->
case IncrementalAction
incrementalAction of
ToCommit UTxO
utxo' ->
if SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
openVersion
then
Head.CloseUnusedInc
{ $sel:signature:CloseInitial :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall {k} (a :: k). MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
signatures
, $sel:alreadyCommittedUTxOHash:CloseInitial :: Signature
alreadyCommittedUTxOHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ UTxOType Tx -> ByteString
forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO UTxO
UTxOType Tx
utxo'
}
else
Head.CloseUsedInc
{ $sel:signature:CloseInitial :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall {k} (a :: k). MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
signatures
, $sel:alreadyCommittedUTxOHash:CloseInitial :: Signature
alreadyCommittedUTxOHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ UTxOType Tx -> ByteString
forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO UTxO
UTxOType Tx
utxo'
}
ToDecommit UTxO
utxo' ->
if SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
openVersion
then Head.CloseUnusedDec{$sel:signature:CloseInitial :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall {k} (a :: k). MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
signatures}
else
Head.CloseUsedDec
{ $sel:signature:CloseInitial :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall {k} (a :: k). MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
signatures
, $sel:alreadyDecommittedUTxOHash:CloseInitial :: Signature
alreadyDecommittedUTxOHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ UTxOType Tx -> ByteString
forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO UTxO
UTxOType Tx
utxo'
}
IncrementalAction
NoThing -> Head.CloseAny{$sel:signature:CloseInitial :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall {k} (a :: k). MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
signatures}
headOutputAfter :: TxOut CtxTx Era
headOutputAfter =
(TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx Era)
-> TxOut CtxUTxO -> TxOut CtxTx Era
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxTx Era
-> TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx Era
forall a b. a -> b -> a
const TxOutDatum CtxTx Era
headDatumAfter) TxOut CtxUTxO
headOutputBefore
headDatumAfter :: TxOutDatum CtxTx Era
headDatumAfter =
State -> TxOutDatum CtxTx Era
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (State -> TxOutDatum CtxTx Era) -> State -> TxOutDatum CtxTx Era
forall a b. (a -> b) -> a -> b
$
ClosedDatum -> State
Head.Closed
Head.ClosedDatum
{ $sel:snapshotNumber:ClosedDatum :: SnapshotNumber
snapshotNumber =
SnapshotNumber -> SnapshotNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SnapshotNumber -> SnapshotNumber)
-> (Snapshot Tx -> SnapshotNumber) -> Snapshot Tx -> SnapshotNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshot Tx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number (Snapshot Tx -> SnapshotNumber) -> Snapshot Tx -> SnapshotNumber
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot
, $sel:utxoHash:ClosedDatum :: Signature
utxoHash =
ByteString -> Signature
ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> Signature)
-> (UTxOType Tx -> ByteString) -> UTxOType Tx -> Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxOType Tx -> ByteString
forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO (UTxOType Tx -> Signature) -> UTxOType Tx -> Signature
forall a b. (a -> b) -> a -> b
$ Snapshot Tx -> UTxOType Tx
forall tx. Snapshot tx -> UTxOType tx
utxo (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot)
, $sel:alphaUTxOHash:ClosedDatum :: Signature
alphaUTxOHash =
case CloseRedeemer
closeRedeemer of
Head.CloseUsedInc{} ->
ByteString -> Signature
ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> Signature)
-> (Snapshot Tx -> ByteString) -> Snapshot Tx -> Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx (UTxO -> ByteString)
-> (Snapshot Tx -> UTxO) -> Snapshot Tx -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> Maybe UTxO -> UTxO
forall a. a -> Maybe a -> a
fromMaybe UTxO
forall a. Monoid a => a
mempty (Maybe UTxO -> UTxO)
-> (Snapshot Tx -> Maybe UTxO) -> Snapshot Tx -> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshot Tx -> Maybe UTxO
Snapshot Tx -> Maybe (UTxOType Tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit (Snapshot Tx -> Signature) -> Snapshot Tx -> Signature
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot
CloseRedeemer
_ -> ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxO
UTxOType Tx
forall a. Monoid a => a
mempty
, $sel:omegaUTxOHash:ClosedDatum :: Signature
omegaUTxOHash =
case CloseRedeemer
closeRedeemer of
Head.CloseUnusedDec{} ->
ByteString -> Signature
ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> Signature)
-> (Snapshot Tx -> ByteString) -> Snapshot Tx -> Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx (UTxO -> ByteString)
-> (Snapshot Tx -> UTxO) -> Snapshot Tx -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> Maybe UTxO -> UTxO
forall a. a -> Maybe a -> a
fromMaybe UTxO
forall a. Monoid a => a
mempty (Maybe UTxO -> UTxO)
-> (Snapshot Tx -> Maybe UTxO) -> Snapshot Tx -> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshot Tx -> Maybe UTxO
Snapshot Tx -> Maybe (UTxOType Tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit (Snapshot Tx -> Signature) -> Snapshot Tx -> Signature
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot
CloseRedeemer
_ -> ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxO
UTxOType Tx
forall a. Monoid a => a
mempty
, $sel:parties:ClosedDatum :: [Party]
parties = [Party]
openParties
, POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:ClosedDatum :: POSIXTime
contestationDeadline
, $sel:contestationPeriod:ClosedDatum :: ContestationPeriod
contestationPeriod = ContestationPeriod
openContestationPeriod
, $sel:headId:ClosedDatum :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
, $sel:contesters:ClosedDatum :: [PubKeyHash]
contesters = []
, $sel:version:ClosedDatum :: SnapshotNumber
version = SnapshotVersion -> SnapshotNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotVersion
openVersion
}
contestationDeadline :: POSIXTime
contestationDeadline =
POSIXTime -> ContestationPeriod -> POSIXTime
addContestationPeriod (UTCTime -> POSIXTime
posixFromUTCTime UTCTime
utcTime) ContestationPeriod
openContestationPeriod