{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.Tx.Close where

import Hydra.Cardano.Api hiding (utxo)
import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
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.DepositPeriod qualified as OnChain
import Hydra.Data.Party qualified as OnChain
import Hydra.Ledger.Cardano.Builder (unsafeBuildTransaction)
import Hydra.Plutus.Extras.Time (posixFromUTCTime, posixToUTCTime)
import Hydra.Tx (
  ConfirmedSnapshot (..),
  HeadId,
  ScriptRegistry (headReference),
  Snapshot (..),
  SnapshotNumber,
  SnapshotVersion,
  accumulatorInHead,
  commitOutputsHash,
  decommitOutputsHash,
  fromChainSnapshotNumber,
  getSnapshot,
  hasPendingAction,
  headIdToCurrencySymbol,
  headReference,
  pendingActionApplied,
 )
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.Crypto (MultiSignature, observedSignatures, toPlutusSignatures)
import Hydra.Tx.Utils (IncrementalAction (..), findStateToken, mkHydraHeadV2TxName)
import PlutusLedgerApi.V3 (toBuiltin)

-- * Construction

type PointInTime = (SlotNo, UTCTime)

-- | Representation of the head thread UTxO while the head is in the Open state.
data OpenThreadOutput = OpenThreadOutput
  { OpenThreadOutput -> (TxIn, TxOut CtxUTxO)
openThreadUTxO :: (TxIn, TxOut CtxUTxO)
  , OpenThreadOutput -> ContestationPeriod
openContestationPeriod :: OnChain.ContestationPeriod
  , OpenThreadOutput -> DepositPeriod
openDepositPeriod :: OnChain.DepositPeriod
  , 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)

-- | Whether a head at the given open version can be closed with the snapshot,
-- such that the closed head can later be fanned out.
--
-- The head validator only accepts a snapshot signed at the open version
-- ('Head.CloseInitial', 'Head.CloseAny', 'Head.CloseUnused') or one before
-- ('Head.CloseUsed'). The latter stores the snapshot's applied accumulator,
-- which only matches the head value if the version bump was this snapshot's
-- own increment or decrement. For a snapshot without a pending action the
-- version moved on through another snapshot's settlement, so the closed head
-- could never be fanned out: a later snapshot this node has not adopted, or an
-- earlier commit this snapshot dropped once its increment could no longer
-- land, which landed after all. A settling decommit is never dropped (the
-- snapshot request handler requires every request at its version to carry
-- it), so a confirmed snapshot never lags the head by a decommit it already
-- accounts for.
isClosableAt :: SnapshotVersion -> Snapshot tx -> Bool
isClosableAt :: forall tx. SnapshotVersion -> Snapshot tx -> Bool
isClosableAt SnapshotVersion
openVersion snapshot :: Snapshot tx
snapshot@Snapshot{SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version} =
  SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
openVersion
    Bool -> Bool -> Bool
|| (SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1 SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
openVersion Bool -> Bool -> Bool
&& Snapshot tx -> Bool
forall tx. Snapshot tx -> Bool
hasPendingAction Snapshot tx
snapshot)

-- | Create a transaction closing a head with either the initial snapshot or
-- with a multi-signed confirmed snapshot.
closeTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  -- | Head identifier
  HeadId ->
  -- | Last known version of the open head.
  SnapshotVersion ->
  -- | Snapshot with instructions how to close the head.
  ConfirmedSnapshot Tx ->
  -- | Lower validity slot number, usually a current or quite recent slot number.
  SlotNo ->
  -- | Upper validity slot and UTC time to compute the contestation deadline time.
  PointInTime ->
  -- | Everything needed to spend the Head state-machine output.
  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]
-> Set HashableScriptData
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall build era.
(Applicative (BuildTxWith build), IsBabbageBasedEra era) =>
[TxIn]
-> Set HashableScriptData
-> TxBodyContent build era
-> TxBodyContent build era
addTxInsReference [TxIn
headScriptRef] Set HashableScriptData
forall a. Monoid a => a
mempty
      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
mkHydraHeadV2TxName 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
    , DepositPeriod
$sel:openDepositPeriod:OpenThreadOutput :: OpenThreadOutput -> DepositPeriod
openDepositPeriod :: DepositPeriod
openDepositPeriod
    , [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
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> HashableScriptData
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript PlutusScriptV3
Head.validatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
headRedeemer

  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)

  headRedeemer :: HashableScriptData
headRedeemer = Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Input -> HashableScriptData) -> Input -> HashableScriptData
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} ->
        let accHash :: ToBuiltin ByteString
accHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ HydraAccumulator -> ByteString
Accumulator.getAccumulatorHash HydraAccumulator
accumulator
            appliedAccHash :: ToBuiltin ByteString
appliedAccHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ HydraAccumulator -> ByteString
Accumulator.getAccumulatorHash HydraAccumulator
appliedAccumulator
            decommitHash :: ToBuiltin ByteString
decommitHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ Snapshot Tx -> ByteString
forall tx. IsTx tx => Snapshot tx -> ByteString
decommitOutputsHash Snapshot Tx
snapshot
            commitHash :: ToBuiltin ByteString
commitHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ Snapshot Tx -> ByteString
forall tx. IsTx tx => Snapshot tx -> ByteString
commitOutputsHash Snapshot Tx
snapshot
            sig :: [Signature]
sig = MultiSignature (Snapshot Tx) -> [Signature]
forall a. MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
signatures
         in if SnapshotVersion -> Snapshot Tx -> Bool
forall tx. SnapshotVersion -> Snapshot tx -> Bool
pendingActionApplied SnapshotVersion
openVersion Snapshot Tx
snapshot
              then
                Head.CloseUsed{$sel:signature:CloseInitial :: [Signature]
signature = [Signature]
sig, $sel:accumulatorHash:CloseInitial :: Signature
accumulatorHash = Signature
ToBuiltin ByteString
accHash, $sel:appliedAccumulatorHash:CloseInitial :: Signature
appliedAccumulatorHash = Signature
ToBuiltin ByteString
appliedAccHash, $sel:decommitOutputsHash:CloseInitial :: Signature
decommitOutputsHash = Signature
ToBuiltin ByteString
decommitHash, $sel:commitOutputsHash:CloseInitial :: Signature
commitOutputsHash = Signature
ToBuiltin ByteString
commitHash}
              else case IncrementalAction
incrementalAction of
                IncrementalAction
NoThing ->
                  Head.CloseAny{$sel:signature:CloseInitial :: [Signature]
signature = [Signature]
sig, $sel:accumulatorHash:CloseInitial :: Signature
accumulatorHash = Signature
ToBuiltin ByteString
accHash, $sel:appliedAccumulatorHash:CloseInitial :: Signature
appliedAccumulatorHash = Signature
ToBuiltin ByteString
appliedAccHash, $sel:decommitOutputsHash:CloseInitial :: Signature
decommitOutputsHash = Signature
ToBuiltin ByteString
decommitHash, $sel:commitOutputsHash:CloseInitial :: Signature
commitOutputsHash = Signature
ToBuiltin ByteString
commitHash}
                IncrementalAction
_ ->
                  Head.CloseUnused{$sel:signature:CloseInitial :: [Signature]
signature = [Signature]
sig, $sel:accumulatorHash:CloseInitial :: Signature
accumulatorHash = Signature
ToBuiltin ByteString
accHash, $sel:appliedAccumulatorHash:CloseInitial :: Signature
appliedAccumulatorHash = Signature
ToBuiltin ByteString
appliedAccHash, $sel:decommitOutputsHash:CloseInitial :: Signature
decommitOutputsHash = Signature
ToBuiltin ByteString
decommitHash, $sel:commitOutputsHash:CloseInitial :: Signature
commitOutputsHash = Signature
ToBuiltin ByteString
commitHash}

  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

  snapshot :: Snapshot Tx
snapshot@Snapshot{SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number, UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo, Maybe (UTxOType Tx)
utxoToCommit :: Maybe (UTxOType Tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit, Maybe (UTxOType Tx)
utxoToDecommit :: Maybe (UTxOType Tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit, HydraAccumulator
accumulator :: HydraAccumulator
$sel:accumulator:Snapshot :: forall tx. Snapshot tx -> HydraAccumulator
accumulator, HydraAccumulator
appliedAccumulator :: HydraAccumulator
$sel:appliedAccumulator:Snapshot :: forall tx. Snapshot tx -> HydraAccumulator
appliedAccumulator} = ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot

  -- What the head holds at close time: a pending decommit is inside until its
  -- decrement happened, a pending commit only once its increment happened.
  utxoInHead :: UTxO Era
utxoInHead
    | SnapshotVersion -> Snapshot Tx -> Bool
forall tx. SnapshotVersion -> Snapshot tx -> Bool
pendingActionApplied SnapshotVersion
openVersion Snapshot Tx
snapshot = UTxO Era
UTxOType Tx
utxo UTxO Era -> UTxO Era -> UTxO Era
forall a. Semigroup a => a -> a -> a
<> Maybe (UTxO Era) -> UTxO Era
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe (UTxO Era)
Maybe (UTxOType Tx)
utxoToCommit
    | Bool
otherwise = UTxO Era
UTxOType Tx
utxo UTxO Era -> UTxO Era -> UTxO Era
forall a. Semigroup a => a -> a -> a
<> Maybe (UTxO Era) -> UTxO Era
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe (UTxO Era)
Maybe (UTxOType Tx)
utxoToDecommit

  -- Lovelace in the head UTxO not attributable to any L2 UTxO value (the
  -- min-UTxO overhead). Computed once at Close and propagated unchanged through
  -- Contest and partial fanout steps so the on-chain conservation check can use
  -- strict equality rather than >=.
  headAdaOverhead :: Integer
headAdaOverhead =
    let Coin Integer
headLovelace = Value -> Coin
selectLovelace (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
headOutputBefore)
        Coin Integer
utxoLovelace = Value -> Coin
selectLovelace (UTxO Era -> Value
forall era. UTxO era -> Value
UTxO.totalValue UTxO Era
utxoInHead)
     in Integer
headLovelace Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
utxoLovelace

  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 :: Integer
snapshotNumber = SnapshotNumber -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotNumber
number
          , $sel:parties:ClosedDatum :: [Party]
parties = [Party]
openParties
          , POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:ClosedDatum :: POSIXTime
contestationDeadline
          , $sel:contestationPeriod:ClosedDatum :: ContestationPeriod
contestationPeriod = ContestationPeriod
openContestationPeriod
          , $sel:depositPeriod:ClosedDatum :: DepositPeriod
depositPeriod = DepositPeriod
openDepositPeriod
          , $sel:headId:ClosedDatum :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
          , $sel:contesters:ClosedDatum :: [PubKeyHash]
contesters = []
          , $sel:version:ClosedDatum :: Integer
version = SnapshotVersion -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotVersion
openVersion
          , $sel:accumulatorCommitment:ClosedDatum :: BuiltinBLS12_381_G1_Element
accumulatorCommitment = HydraAccumulator -> BuiltinBLS12_381_G1_Element
Accumulator.getAccumulatorCommitment (SnapshotVersion -> Snapshot Tx -> HydraAccumulator
forall tx. SnapshotVersion -> Snapshot tx -> HydraAccumulator
accumulatorInHead SnapshotVersion
openVersion Snapshot Tx
snapshot)
          , Integer
headAdaOverhead :: Integer
$sel:headAdaOverhead:ClosedDatum :: Integer
headAdaOverhead
          }

  contestationDeadline :: POSIXTime
contestationDeadline =
    POSIXTime -> ContestationPeriod -> POSIXTime
addContestationPeriod (UTCTime -> POSIXTime
posixFromUTCTime UTCTime
utcTime) ContestationPeriod
openContestationPeriod

-- * Observation

data CloseObservation = CloseObservation
  { CloseObservation -> HeadId
headId :: HeadId
  , CloseObservation -> SnapshotNumber
snapshotNumber :: SnapshotNumber
  , CloseObservation -> UTCTime
contestationDeadline :: UTCTime
  , CloseObservation -> MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
  -- ^ Multisignature of the closing snapshot, empty for the initial snapshot.
  }
  deriving stock (Int -> CloseObservation -> ShowS
[CloseObservation] -> ShowS
CloseObservation -> String
(Int -> CloseObservation -> ShowS)
-> (CloseObservation -> String)
-> ([CloseObservation] -> ShowS)
-> Show CloseObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CloseObservation -> ShowS
showsPrec :: Int -> CloseObservation -> ShowS
$cshow :: CloseObservation -> String
show :: CloseObservation -> String
$cshowList :: [CloseObservation] -> ShowS
showList :: [CloseObservation] -> ShowS
Show, CloseObservation -> CloseObservation -> Bool
(CloseObservation -> CloseObservation -> Bool)
-> (CloseObservation -> CloseObservation -> Bool)
-> Eq CloseObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CloseObservation -> CloseObservation -> Bool
== :: CloseObservation -> CloseObservation -> Bool
$c/= :: CloseObservation -> CloseObservation -> Bool
/= :: CloseObservation -> CloseObservation -> Bool
Eq, (forall x. CloseObservation -> Rep CloseObservation x)
-> (forall x. Rep CloseObservation x -> CloseObservation)
-> Generic CloseObservation
forall x. Rep CloseObservation x -> CloseObservation
forall x. CloseObservation -> Rep CloseObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CloseObservation -> Rep CloseObservation x
from :: forall x. CloseObservation -> Rep CloseObservation x
$cto :: forall x. Rep CloseObservation x -> CloseObservation
to :: forall x. Rep CloseObservation x -> CloseObservation
Generic)
  deriving anyclass ([CloseObservation] -> Value
[CloseObservation] -> Encoding
CloseObservation -> Bool
CloseObservation -> Value
CloseObservation -> Encoding
(CloseObservation -> Value)
-> (CloseObservation -> Encoding)
-> ([CloseObservation] -> Value)
-> ([CloseObservation] -> Encoding)
-> (CloseObservation -> Bool)
-> ToJSON CloseObservation
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: CloseObservation -> Value
toJSON :: CloseObservation -> Value
$ctoEncoding :: CloseObservation -> Encoding
toEncoding :: CloseObservation -> Encoding
$ctoJSONList :: [CloseObservation] -> Value
toJSONList :: [CloseObservation] -> Value
$ctoEncodingList :: [CloseObservation] -> Encoding
toEncodingList :: [CloseObservation] -> Encoding
$comitField :: CloseObservation -> Bool
omitField :: CloseObservation -> Bool
ToJSON, Maybe CloseObservation
Value -> Parser [CloseObservation]
Value -> Parser CloseObservation
(Value -> Parser CloseObservation)
-> (Value -> Parser [CloseObservation])
-> Maybe CloseObservation
-> FromJSON CloseObservation
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser CloseObservation
parseJSON :: Value -> Parser CloseObservation
$cparseJSONList :: Value -> Parser [CloseObservation]
parseJSONList :: Value -> Parser [CloseObservation]
$comittedField :: Maybe CloseObservation
omittedField :: Maybe CloseObservation
FromJSON)

-- | Identify a close tx by lookup up the input spending the Head output and
-- decoding its redeemer.
observeCloseTx ::
  -- | A UTxO set to lookup tx inputs
  UTxO ->
  Tx ->
  Maybe CloseObservation
observeCloseTx :: UTxO Era -> Tx -> Maybe CloseObservation
observeCloseTx UTxO Era
utxo Tx
tx = do
  let inputUTxO :: UTxO Era
inputUTxO = UTxO Era -> Tx -> UTxO Era
resolveInputsUTxO UTxO Era
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- UTxO Era
-> PlutusScript PlutusScriptV3 -> Maybe (TxIn, TxOut CtxUTxO)
forall lang.
IsPlutusScriptLanguage lang =>
UTxO Era -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript UTxO Era
inputUTxO PlutusScript PlutusScriptV3
Head.validatorScript
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  HashableScriptData
oldHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO
headOutput
  State
datum <- HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
oldHeadDatum
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  case (State
datum, Input
redeemer) of
    (Head.Open Head.OpenDatum{}, Head.Close CloseRedeemer
closeRedeemer) -> do
      (TxIn
_, TxOut CtxUTxO
newHeadOutput) <- UTxO Era
-> PlutusScript PlutusScriptV3 -> Maybe (TxIn, TxOut CtxUTxO)
forall lang.
IsPlutusScriptLanguage lang =>
UTxO Era -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript (Tx -> UTxO Era
utxoFromTx Tx
tx) PlutusScript PlutusScriptV3
Head.validatorScript
      HashableScriptData
newHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO
newHeadOutput
      (POSIXTime
closeContestationDeadline, Integer
onChainSnapshotNumber) <- case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
newHeadDatum of
        Just (Head.Closed Head.ClosedDatum{POSIXTime
$sel:contestationDeadline:ClosedDatum :: ClosedDatum -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, Integer
$sel:snapshotNumber:ClosedDatum :: ClosedDatum -> Integer
snapshotNumber :: Integer
snapshotNumber}) ->
          (POSIXTime, Integer) -> Maybe (POSIXTime, Integer)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (POSIXTime
contestationDeadline, Integer
snapshotNumber)
        Maybe State
_ -> Maybe (POSIXTime, Integer)
forall a. Maybe a
Nothing
      CloseObservation -> Maybe CloseObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        CloseObservation
          { HeadId
$sel:headId:CloseObservation :: HeadId
headId :: HeadId
headId
          , $sel:snapshotNumber:CloseObservation :: SnapshotNumber
snapshotNumber = Integer -> SnapshotNumber
fromChainSnapshotNumber Integer
onChainSnapshotNumber
          , $sel:contestationDeadline:CloseObservation :: UTCTime
contestationDeadline = POSIXTime -> UTCTime
posixToUTCTime POSIXTime
closeContestationDeadline
          , $sel:signatures:CloseObservation :: MultiSignature (Snapshot Tx)
signatures = CloseRedeemer -> MultiSignature (Snapshot Tx)
closeSignatures CloseRedeemer
closeRedeemer
          }
    (State, Input)
_ -> Maybe CloseObservation
forall a. Maybe a
Nothing
 where
  closeSignatures :: Head.CloseRedeemer -> MultiSignature (Snapshot Tx)
  closeSignatures :: CloseRedeemer -> MultiSignature (Snapshot Tx)
closeSignatures = \case
    CloseRedeemer
Head.CloseInitial -> MultiSignature (Snapshot Tx)
forall a. Monoid a => a
mempty
    Head.CloseAny{[Signature]
$sel:signature:CloseInitial :: CloseRedeemer -> [Signature]
signature :: [Signature]
signature} -> [Signature] -> MultiSignature (Snapshot Tx)
forall a. [Signature] -> MultiSignature a
observedSignatures [Signature]
signature
    Head.CloseUnused{[Signature]
$sel:signature:CloseInitial :: CloseRedeemer -> [Signature]
signature :: [Signature]
signature} -> [Signature] -> MultiSignature (Snapshot Tx)
forall a. [Signature] -> MultiSignature a
observedSignatures [Signature]
signature
    Head.CloseUsed{[Signature]
$sel:signature:CloseInitial :: CloseRedeemer -> [Signature]
signature :: [Signature]
signature} -> [Signature] -> MultiSignature (Snapshot Tx)
forall a. [Signature] -> MultiSignature a
observedSignatures [Signature]
signature