module Hydra.Tx.Increment where

import Hydra.Cardano.Api
import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Data.List qualified as List
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Deposit qualified as Deposit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Ledger.Cardano.Builder (
  unsafeBuildTransaction,
 )
import Hydra.Plutus (depositValidatorScript)
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.ContestationPeriod qualified as ContestationPeriod
import Hydra.Tx.Crypto (MultiSignature (..), toPlutusSignatures)
import Hydra.Tx.DepositPeriod qualified as DepositPeriod
import Hydra.Tx.HeadId (HeadId, headIdToCurrencySymbol)
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.IsTx (hashUTxO)
import Hydra.Tx.Party (partyToChain)
import Hydra.Tx.ScriptRegistry (ScriptRegistry, headReference)
import Hydra.Tx.Snapshot (Snapshot (..), SnapshotVersion, fromChainSnapshotVersion)
import Hydra.Tx.Utils (findStateToken, mkHydraHeadV2TxName)
import PlutusLedgerApi.V3 (toBuiltin)

-- * Construction

-- | Construct a _increment_ transaction which takes as input some 'UTxO'
-- locked at v_deposit and make it available on L2.
incrementTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  -- | Head seed and identifier
  (TxIn, HeadId) ->
  -- | Parameters of the head.
  HeadParameters ->
  -- | Everything needed to spend the Head state-machine output.
  (TxIn, TxOut CtxUTxO) ->
  -- | Confirmed Snapshot
  Snapshot Tx ->
  -- | Deposit output UTxO to be spent in increment transaction
  UTxO ->
  SlotNo ->
  MultiSignature (Snapshot Tx) ->
  Tx
incrementTx :: ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, HeadId)
-> HeadParameters
-> (TxIn, TxOut CtxUTxO)
-> Snapshot Tx
-> UTxO Era
-> SlotNo
-> MultiSignature (Snapshot Tx)
-> Tx
incrementTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk (TxIn
seedTxIn, HeadId
headId) HeadParameters
headParameters (TxIn
headInput, TxOut CtxUTxO
headOutput) Snapshot Tx
snapshot UTxO Era
depositScriptUTxO SlotNo
upperValiditySlot MultiSignature (Snapshot Tx)
sigs =
  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), (TxIn
depositIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness)]
      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
headOutput']
      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
& TxValidityUpperBound Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxValidityUpperBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityUpperBound (SlotNo -> TxValidityUpperBound Era
TxValidityUpperBound SlotNo
upperValiditySlot)
      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
"IncrementTx")
 where
  headRedeemer :: HashableScriptData
headRedeemer =
    Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Input -> HashableScriptData) -> Input -> HashableScriptData
forall a b. (a -> b) -> a -> b
$
      IncrementRedeemer -> Input
Head.Increment
        Head.IncrementRedeemer
          { $sel:signature:IncrementRedeemer :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall a. MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
sigs
          , $sel:snapshotNumber:IncrementRedeemer :: Integer
snapshotNumber = SnapshotNumber -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotNumber
number
          , $sel:increment:IncrementRedeemer :: TxOutRef
increment = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
depositIn
          , $sel:decommitOutputsHash:IncrementRedeemer :: Signature
decommitOutputsHash = 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 Era -> Maybe (UTxO Era) -> UTxO Era
forall a. a -> Maybe a -> a
fromMaybe UTxO Era
forall a. Monoid a => a
mempty Maybe (UTxO Era)
Maybe (UTxOType Tx)
utxoToDecommit)
          }

  HeadParameters{[Party]
parties :: [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod, DepositPeriod
depositPeriod :: DepositPeriod
$sel:depositPeriod:HeadParameters :: HeadParameters -> DepositPeriod
depositPeriod} = HeadParameters
headParameters

  headOutput' :: TxOut CtxTx Era
headOutput' =
    TxOut CtxUTxO
headOutput
      TxOut CtxUTxO
-> (TxOut CtxUTxO -> TxOut CtxTx Era) -> TxOut CtxTx Era
forall a b. a -> (a -> b) -> b
& (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 CtxTx Era
-> (TxOut CtxTx Era -> TxOut CtxTx Era) -> TxOut CtxTx Era
forall a b. a -> (a -> b) -> b
& (Value -> Value) -> TxOut CtxTx Era -> TxOut CtxTx Era
forall era ctx.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
depositedValue)

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

  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

  incrementAccumulatorHash :: ByteString
incrementAccumulatorHash = HydraAccumulator -> ByteString
Accumulator.getAccumulatorHash HydraAccumulator
accumulator

  prevHeadAdaOverhead :: Integer
prevHeadAdaOverhead =
    case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData (HashableScriptData -> Maybe State)
-> Maybe HashableScriptData -> Maybe State
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO
headOutput) of
      Just (Head.Open Head.OpenDatum{Integer
headAdaOverhead :: Integer
$sel:headAdaOverhead:OpenDatum :: OpenDatum -> Integer
headAdaOverhead}) -> Integer
headAdaOverhead
      Maybe State
_ -> Integer
0

  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
$
      OpenDatum -> State
Head.Open
        Head.OpenDatum
          { $sel:headSeed:OpenDatum :: TxOutRef
headSeed = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
seedTxIn
          , $sel:parties:OpenDatum :: [Party]
Head.parties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
          , $sel:contestationPeriod:OpenDatum :: ContestationPeriod
contestationPeriod = ContestationPeriod -> ContestationPeriod
ContestationPeriod.toChain ContestationPeriod
contestationPeriod
          , $sel:depositPeriod:OpenDatum :: DepositPeriod
depositPeriod = DepositPeriod -> DepositPeriod
DepositPeriod.toChain DepositPeriod
depositPeriod
          , $sel:headId:OpenDatum :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
          , $sel:version:OpenDatum :: Integer
version = SnapshotVersion -> Integer
forall a. Integral a => a -> Integer
toInteger SnapshotVersion
version Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
          , $sel:accumulatorHash:OpenDatum :: Signature
accumulatorHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin ByteString
incrementAccumulatorHash
          , $sel:headAdaOverhead:OpenDatum :: Integer
headAdaOverhead = Integer
prevHeadAdaOverhead
          }

  depositedValue :: Value
depositedValue = ((TxIn, TxOut CtxUTxO) -> Value)
-> [(TxIn, TxOut CtxUTxO)] -> Value
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue (TxOut CtxUTxO -> Value)
-> ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> (TxIn, TxOut CtxUTxO)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO
forall a b. (a, b) -> b
snd) ([(TxIn, TxOut CtxUTxO)] -> Value)
-> [(TxIn, TxOut CtxUTxO)] -> Value
forall a b. (a -> b) -> a -> b
$ UTxO Era -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList (UTxO Era -> Maybe (UTxO Era) -> UTxO Era
forall a. a -> Maybe a -> a
fromMaybe UTxO Era
forall a. Monoid a => a
mempty Maybe (UTxO Era)
Maybe (UTxOType Tx)
utxoToCommit)

  -- NOTE: we expect always a single output from a deposit tx
  (TxIn
depositIn, TxOut CtxUTxO
_) = [(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO)
forall a. HasCallStack => [a] -> a
List.head ([(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO))
-> [(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ UTxO Era -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO Era
depositScriptUTxO

  depositRedeemer :: HashableScriptData
depositRedeemer = Redeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Redeemer -> HashableScriptData) -> Redeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ DepositRedeemer -> Redeemer
Deposit.redeemer DepositRedeemer
Deposit.Claim

  depositWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness =
    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
$
        PlutusScript PlutusScriptV3
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript PlutusScriptV3
depositValidatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
depositRedeemer

  Snapshot{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, SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version, SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number, HydraAccumulator
accumulator :: HydraAccumulator
$sel:accumulator:Snapshot :: forall tx. Snapshot tx -> HydraAccumulator
accumulator} = Snapshot Tx
snapshot

-- * Observation

data IncrementObservation = IncrementObservation
  { IncrementObservation -> HeadId
headId :: HeadId
  , IncrementObservation -> SnapshotVersion
newVersion :: SnapshotVersion
  , IncrementObservation -> TxId
depositTxId :: TxId
  , IncrementObservation -> UTxO Era
deposited :: UTxO
  }
  deriving stock (Int -> IncrementObservation -> ShowS
[IncrementObservation] -> ShowS
IncrementObservation -> String
(Int -> IncrementObservation -> ShowS)
-> (IncrementObservation -> String)
-> ([IncrementObservation] -> ShowS)
-> Show IncrementObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncrementObservation -> ShowS
showsPrec :: Int -> IncrementObservation -> ShowS
$cshow :: IncrementObservation -> String
show :: IncrementObservation -> String
$cshowList :: [IncrementObservation] -> ShowS
showList :: [IncrementObservation] -> ShowS
Show, IncrementObservation -> IncrementObservation -> Bool
(IncrementObservation -> IncrementObservation -> Bool)
-> (IncrementObservation -> IncrementObservation -> Bool)
-> Eq IncrementObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IncrementObservation -> IncrementObservation -> Bool
== :: IncrementObservation -> IncrementObservation -> Bool
$c/= :: IncrementObservation -> IncrementObservation -> Bool
/= :: IncrementObservation -> IncrementObservation -> Bool
Eq, (forall x. IncrementObservation -> Rep IncrementObservation x)
-> (forall x. Rep IncrementObservation x -> IncrementObservation)
-> Generic IncrementObservation
forall x. Rep IncrementObservation x -> IncrementObservation
forall x. IncrementObservation -> Rep IncrementObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IncrementObservation -> Rep IncrementObservation x
from :: forall x. IncrementObservation -> Rep IncrementObservation x
$cto :: forall x. Rep IncrementObservation x -> IncrementObservation
to :: forall x. Rep IncrementObservation x -> IncrementObservation
Generic)
  deriving anyclass ([IncrementObservation] -> Value
[IncrementObservation] -> Encoding
IncrementObservation -> Bool
IncrementObservation -> Value
IncrementObservation -> Encoding
(IncrementObservation -> Value)
-> (IncrementObservation -> Encoding)
-> ([IncrementObservation] -> Value)
-> ([IncrementObservation] -> Encoding)
-> (IncrementObservation -> Bool)
-> ToJSON IncrementObservation
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: IncrementObservation -> Value
toJSON :: IncrementObservation -> Value
$ctoEncoding :: IncrementObservation -> Encoding
toEncoding :: IncrementObservation -> Encoding
$ctoJSONList :: [IncrementObservation] -> Value
toJSONList :: [IncrementObservation] -> Value
$ctoEncodingList :: [IncrementObservation] -> Encoding
toEncodingList :: [IncrementObservation] -> Encoding
$comitField :: IncrementObservation -> Bool
omitField :: IncrementObservation -> Bool
ToJSON, Maybe IncrementObservation
Value -> Parser [IncrementObservation]
Value -> Parser IncrementObservation
(Value -> Parser IncrementObservation)
-> (Value -> Parser [IncrementObservation])
-> Maybe IncrementObservation
-> FromJSON IncrementObservation
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser IncrementObservation
parseJSON :: Value -> Parser IncrementObservation
$cparseJSONList :: Value -> Parser [IncrementObservation]
parseJSONList :: Value -> Parser [IncrementObservation]
$comittedField :: Maybe IncrementObservation
omittedField :: Maybe IncrementObservation
FromJSON)

observeIncrementTx ::
  NetworkId ->
  UTxO ->
  Tx ->
  Maybe IncrementObservation
observeIncrementTx :: NetworkId -> UTxO Era -> Tx -> Maybe IncrementObservation
observeIncrementTx NetworkId
networkId 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
  (TxIn TxId
depositTxId TxIx
_, TxOut CtxUTxO
depositOutput) <- 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
depositValidatorScript
  HashableScriptData
dat <- 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
depositOutput
  (CurrencySymbol
_, POSIXTime
_, [Commit]
onChainDeposits) <- HashableScriptData -> Maybe DepositDatum
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
dat :: Maybe Deposit.DepositDatum
  UTxO Era
deposited <- do
    [(TxIn, TxOut CtxUTxO)]
depositedUTxO <- (Commit -> Maybe (TxIn, TxOut CtxUTxO))
-> [Commit] -> Maybe [(TxIn, TxOut CtxUTxO)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Network -> Commit -> Maybe (TxIn, TxOut CtxUTxO)
Commit.deserializeCommit (NetworkId -> Network
toShelleyNetwork NetworkId
networkId)) [Commit]
onChainDeposits
    UTxO Era -> Maybe (UTxO Era)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO Era -> Maybe (UTxO Era)) -> UTxO Era -> Maybe (UTxO Era)
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO)] -> UTxO Era
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList [(TxIn, TxOut CtxUTxO)]
depositedUTxO
  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.Increment Head.IncrementRedeemer{}) -> 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
      case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
newHeadDatum of
        Just (Head.Open Head.OpenDatum{Integer
$sel:version:OpenDatum :: OpenDatum -> Integer
version :: Integer
version}) ->
          IncrementObservation -> Maybe IncrementObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            IncrementObservation
              { HeadId
$sel:headId:IncrementObservation :: HeadId
headId :: HeadId
headId
              , $sel:newVersion:IncrementObservation :: SnapshotVersion
newVersion = Integer -> SnapshotVersion
fromChainSnapshotVersion Integer
version
              , TxId
$sel:depositTxId:IncrementObservation :: TxId
depositTxId :: TxId
depositTxId
              , UTxO Era
$sel:deposited:IncrementObservation :: UTxO Era
deposited :: UTxO Era
deposited
              }
        Maybe State
_ -> Maybe IncrementObservation
forall a. Maybe a
Nothing
    (State, Input)
_ -> Maybe IncrementObservation
forall a. Maybe a
Nothing