module Hydra.Tx.Deposit where

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

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Api (AllegraEraTxBody (vldtTxBodyL), ValidityInterval (..), bodyTxL, inputsTxBodyL, outputsTxBodyL)
import Control.Lens ((.~), (^.))
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Sequence.Strict qualified as StrictSeq
import Data.Set qualified as Set
import GHC.IsList (toList)
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Deposit qualified as Deposit
import Hydra.Plutus (depositValidatorScript)
import Hydra.Plutus.Extras.Time (posixFromUTCTime, posixToUTCTime)
import Hydra.Tx (CommitBlueprintTx (..), HeadId, currencySymbolToHeadId, headIdToCurrencySymbol, txId)
import Hydra.Tx.Utils (addMetadata, mkHydraHeadV1TxName)
import PlutusLedgerApi.V3 (POSIXTime)

-- * Construction

-- | Builds a deposit transaction to lock funds into the v_deposit script.
depositTx ::
  NetworkId ->
  HeadId ->
  CommitBlueprintTx Tx ->
  -- | Slot to use as upper validity. Will mark the time of creation of the deposit.
  SlotNo ->
  -- | Deposit deadline from which onward the deposit can be recovered.
  UTCTime ->
  Tx
depositTx :: NetworkId
-> HeadId -> CommitBlueprintTx Tx -> SlotNo -> UTCTime -> Tx
depositTx NetworkId
networkId HeadId
headId CommitBlueprintTx Tx
commitBlueprintTx SlotNo
upperSlot UTCTime
deadline =
  Tx (ShelleyLedgerEra Era) -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx (ShelleyLedgerEra Era) -> Tx)
-> Tx (ShelleyLedgerEra Era) -> Tx
forall a b. (a -> b) -> a -> b
$
    Tx -> Tx (ShelleyLedgerEra Era)
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx
      Tx ConwayEra -> (Tx ConwayEra -> Tx ConwayEra) -> Tx ConwayEra
forall a b. a -> (a -> b) -> b
& Tx ConwayEra -> Tx ConwayEra
addDepositInputs
      Tx ConwayEra
-> (Tx ConwayEra -> AlonzoTx ConwayEra) -> AlonzoTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> Tx ConwayEra -> Identity (Tx ConwayEra)
(TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> Tx ConwayEra -> Identity (AlonzoTx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx ConwayEra) (TxBody ConwayEra)
bodyTxL ((TxBody ConwayEra -> Identity (TxBody ConwayEra))
 -> Tx ConwayEra -> Identity (AlonzoTx ConwayEra))
-> ((StrictSeq (TxOut ConwayEra)
     -> Identity (StrictSeq (TxOut ConwayEra)))
    -> TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> (StrictSeq (TxOut ConwayEra)
    -> Identity (StrictSeq (TxOut ConwayEra)))
-> Tx ConwayEra
-> Identity (AlonzoTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra -> Identity (TxBody ConwayEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL ((StrictSeq (TxOut ConwayEra)
  -> Identity (StrictSeq (TxOut ConwayEra)))
 -> Tx ConwayEra -> Identity (AlonzoTx ConwayEra))
-> StrictSeq (TxOut ConwayEra)
-> Tx ConwayEra
-> AlonzoTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut ConwayEra -> StrictSeq (TxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton (TxOut CtxUTxO Era -> TxOut (ShelleyLedgerEra Era)
forall era.
IsShelleyBasedEra era =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut (TxOut CtxUTxO Era -> TxOut (ShelleyLedgerEra Era))
-> TxOut CtxUTxO Era -> TxOut (ShelleyLedgerEra Era)
forall a b. (a -> b) -> a -> b
$ NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut CtxUTxO Era
forall ctx. NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut ctx
mkDepositOutput NetworkId
networkId HeadId
headId UTxO
UTxOType Tx
depositUTxO UTCTime
deadline)
      AlonzoTx ConwayEra
-> (AlonzoTx ConwayEra -> AlonzoTx ConwayEra) -> AlonzoTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> Tx ConwayEra -> Identity (Tx ConwayEra)
(TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> AlonzoTx ConwayEra -> Identity (AlonzoTx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx ConwayEra) (TxBody ConwayEra)
bodyTxL ((TxBody ConwayEra -> Identity (TxBody ConwayEra))
 -> AlonzoTx ConwayEra -> Identity (AlonzoTx ConwayEra))
-> ((ValidityInterval -> Identity ValidityInterval)
    -> TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> (ValidityInterval -> Identity ValidityInterval)
-> AlonzoTx ConwayEra
-> Identity (AlonzoTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Identity ValidityInterval)
-> TxBody ConwayEra -> Identity (TxBody ConwayEra)
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody ConwayEra) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> AlonzoTx ConwayEra -> Identity (AlonzoTx ConwayEra))
-> ValidityInterval -> AlonzoTx ConwayEra -> AlonzoTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ValidityInterval{invalidBefore :: StrictMaybe SlotNo
invalidBefore = StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing, invalidHereafter :: StrictMaybe SlotNo
invalidHereafter = SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
upperSlot}
      AlonzoTx ConwayEra
-> (AlonzoTx ConwayEra -> AlonzoTx ConwayEra) -> AlonzoTx ConwayEra
forall a b. a -> (a -> b) -> b
& TxMetadata -> Tx -> AlonzoTx ConwayEra -> AlonzoTx ConwayEra
addMetadata (Text -> TxMetadata
mkHydraHeadV1TxName Text
"DepositTx") Tx
blueprintTx
 where
  addDepositInputs :: Tx ConwayEra -> Tx ConwayEra
addDepositInputs Tx ConwayEra
tx =
    let newInputs :: Set TxIn
newInputs = Tx ConwayEra
tx Tx ConwayEra
-> Getting (Set TxIn) (Tx ConwayEra) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody ConwayEra -> Const (Set TxIn) (TxBody ConwayEra))
-> Tx ConwayEra -> Const (Set TxIn) (Tx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx ConwayEra) (TxBody ConwayEra)
bodyTxL ((TxBody ConwayEra -> Const (Set TxIn) (TxBody ConwayEra))
 -> Tx ConwayEra -> Const (Set TxIn) (Tx ConwayEra))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody ConwayEra -> Const (Set TxIn) (TxBody ConwayEra))
-> Getting (Set TxIn) (Tx ConwayEra) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody ConwayEra -> Const (Set TxIn) (TxBody ConwayEra)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody ConwayEra) (Set TxIn)
inputsTxBodyL Set TxIn -> Set TxIn -> Set TxIn
forall a. Semigroup a => a -> a -> a
<> [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList (TxIn -> TxIn
toLedgerTxIn (TxIn -> TxIn)
-> ((TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)) -> TxIn)
-> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
-> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)) -> TxIn)
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
depositInputs)
     in Tx ConwayEra
tx Tx ConwayEra -> (Tx ConwayEra -> Tx ConwayEra) -> Tx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> Tx ConwayEra -> Identity (Tx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx ConwayEra) (TxBody ConwayEra)
bodyTxL ((TxBody ConwayEra -> Identity (TxBody ConwayEra))
 -> Tx ConwayEra -> Identity (Tx ConwayEra))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx ConwayEra
-> Identity (Tx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody ConwayEra -> Identity (TxBody ConwayEra)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody ConwayEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx ConwayEra -> Identity (Tx ConwayEra))
-> Set TxIn -> Tx ConwayEra -> Tx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set TxIn
newInputs

  CommitBlueprintTx{$sel:lookupUTxO:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> UTxOType tx
lookupUTxO = UTxOType Tx
depositUTxO, Tx
blueprintTx :: Tx
$sel:blueprintTx:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> tx
blueprintTx} = CommitBlueprintTx Tx
commitBlueprintTx

  depositInputsList :: [Item (Set TxIn)]
depositInputsList = Set TxIn -> [Item (Set TxIn)]
forall l. IsList l => l -> [Item l]
toList (UTxO -> Set TxIn
forall out. UTxO' out -> Set TxIn
UTxO.inputSet UTxO
UTxOType Tx
depositUTxO)

  depositInputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
depositInputs = (,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
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending) (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)))
-> [TxIn] -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Item (Set TxIn)]
[TxIn]
depositInputsList

mkDepositOutput ::
  NetworkId ->
  HeadId ->
  UTxO ->
  UTCTime ->
  TxOut ctx
mkDepositOutput :: forall ctx. NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut ctx
mkDepositOutput NetworkId
networkId HeadId
headId UTxO
depositUTxO UTCTime
deadline =
  AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
    (NetworkId -> AddressInEra
depositAddress NetworkId
networkId)
    Value
depositValue
    TxOutDatum ctx
depositDatum
    ReferenceScript
ReferenceScriptNone
 where
  depositValue :: Value
depositValue = (TxOut CtxUTxO Era -> Value) -> UTxO -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue UTxO
depositUTxO

  deposits :: [Commit]
deposits = ((TxIn, TxOut CtxUTxO Era) -> Maybe Commit)
-> [(TxIn, TxOut CtxUTxO Era)] -> [Commit]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxIn, TxOut CtxUTxO Era) -> Maybe Commit
Commit.serializeCommit ([(TxIn, TxOut CtxUTxO Era)] -> [Commit])
-> [(TxIn, TxOut CtxUTxO Era)] -> [Commit]
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.toList UTxO
depositUTxO

  depositPlutusDatum :: Datum
depositPlutusDatum = (CurrencySymbol, POSIXTime, [Commit]) -> Datum
Deposit.datum (HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId, UTCTime -> POSIXTime
posixFromUTCTime UTCTime
deadline, [Commit]
deposits)

  depositDatum :: TxOutDatum ctx
depositDatum = Datum -> TxOutDatum ctx
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline Datum
depositPlutusDatum

depositAddress :: NetworkId -> AddressInEra
depositAddress :: NetworkId -> AddressInEra
depositAddress NetworkId
networkId = NetworkId -> PlutusScript PlutusScriptV3 -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript PlutusScriptV3
depositValidatorScript

-- * Observation

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

-- | Observe a deposit transaction by decoding the target head id, deposit
-- deadline and deposited utxo in the datum.
--
-- This includes checking whether
-- - the first output is a deposit output
-- - all inputs of deposited utxo are actually spent,
-- - the deposit script output actually contains the deposited value,
-- - an upper validity bound has been set (used as creation slot).
observeDepositTx ::
  NetworkId ->
  Tx ->
  Maybe DepositObservation
observeDepositTx :: NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId Tx
tx = do
  TxOut CtxTx Era
depositOut <- (NonEmpty (TxOut CtxTx Era) -> TxOut CtxTx Era)
-> Maybe (NonEmpty (TxOut CtxTx Era)) -> Maybe (TxOut CtxTx Era)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (TxOut CtxTx Era) -> TxOut CtxTx Era
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head (Maybe (NonEmpty (TxOut CtxTx Era)) -> Maybe (TxOut CtxTx Era))
-> ([TxOut CtxTx Era] -> Maybe (NonEmpty (TxOut CtxTx Era)))
-> [TxOut CtxTx Era]
-> Maybe (TxOut CtxTx Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOut CtxTx Era] -> Maybe (NonEmpty (TxOut CtxTx Era))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([TxOut CtxTx Era] -> Maybe (TxOut CtxTx Era))
-> [TxOut CtxTx Era] -> Maybe (TxOut CtxTx Era)
forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx
  (HeadId
headId, UTxO
deposited, POSIXTime
deadline) <- Network -> TxOut CtxUTxO Era -> Maybe (HeadId, UTxO, POSIXTime)
observeDepositTxOut Network
network (TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx Era
depositOut)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ UTxO -> Bool
spendsAll UTxO
deposited
  SlotNo
created <- Maybe SlotNo
getUpperBound
  DepositObservation -> Maybe DepositObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    DepositObservation
      { HeadId
$sel:headId:DepositObservation :: HeadId
headId :: HeadId
headId
      , $sel:depositTxId:DepositObservation :: TxId
depositTxId = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx
      , UTxO
$sel:deposited:DepositObservation :: UTxO
deposited :: UTxO
deposited
      , SlotNo
$sel:created:DepositObservation :: SlotNo
created :: SlotNo
created
      , $sel:deadline:DepositObservation :: UTCTime
deadline = POSIXTime -> UTCTime
posixToUTCTime POSIXTime
deadline
      }
 where
  spendsAll :: UTxO -> Bool
spendsAll = (TxIn -> Bool) -> Set TxIn -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TxIn -> [TxIn] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` Tx -> [TxIn]
forall era. Tx era -> [TxIn]
txIns' Tx
tx) (Set TxIn -> Bool) -> (UTxO -> Set TxIn) -> UTxO -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> Set TxIn
forall out. UTxO' out -> Set TxIn
UTxO.inputSet

  getUpperBound :: Maybe SlotNo
getUpperBound =
    case Tx
tx Tx -> (Tx -> TxBody Era) -> TxBody Era
forall a b. a -> (a -> b) -> b
& Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody TxBody Era
-> (TxBody Era -> TxBodyContent ViewTx Era)
-> TxBodyContent ViewTx Era
forall a b. a -> (a -> b) -> b
& TxBody Era -> TxBodyContent ViewTx Era
forall era. TxBody era -> TxBodyContent ViewTx era
getTxBodyContent TxBodyContent ViewTx Era
-> (TxBodyContent ViewTx Era -> TxValidityUpperBound)
-> TxValidityUpperBound
forall a b. a -> (a -> b) -> b
& TxBodyContent ViewTx Era -> TxValidityUpperBound
forall build. TxBodyContent build -> TxValidityUpperBound
txValidityUpperBound of
      TxValidityUpperBound{SlotNo
upperBound :: SlotNo
upperBound :: TxValidityUpperBound -> SlotNo
upperBound} -> SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
upperBound
      TxValidityUpperBound
TxValidityNoUpperBound -> Maybe SlotNo
forall a. Maybe a
Nothing

  network :: Network
network = NetworkId -> Network
toShelleyNetwork NetworkId
networkId

observeDepositTxOut :: Network -> TxOut CtxUTxO -> Maybe (HeadId, UTxO, POSIXTime)
observeDepositTxOut :: Network -> TxOut CtxUTxO Era -> Maybe (HeadId, UTxO, POSIXTime)
observeDepositTxOut Network
network TxOut CtxUTxO Era
depositOut = do
  HashableScriptData
dat <- case TxOut CtxUTxO Era -> TxOutDatum CtxUTxO
forall ctx. TxOut ctx -> TxOutDatum ctx
txOutDatum TxOut CtxUTxO Era
depositOut of
    TxOutDatumInline HashableScriptData
d -> HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashableScriptData
d
    TxOutDatum CtxUTxO
_ -> Maybe HashableScriptData
forall a. Maybe a
Nothing
  (CurrencySymbol
headCurrencySymbol, POSIXTime
deadline, [Commit]
onChainDeposits) <- HashableScriptData -> Maybe (CurrencySymbol, POSIXTime, [Commit])
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
dat
  HeadId
headId <- CurrencySymbol -> Maybe HeadId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m HeadId
currencySymbolToHeadId CurrencySymbol
headCurrencySymbol
  UTxO
deposit <- do
    UTxO
depositedUTxO <- [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromList ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> Maybe [(TxIn, TxOut CtxUTxO Era)] -> Maybe UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Commit -> Maybe (TxIn, TxOut CtxUTxO Era))
-> [Commit] -> Maybe [(TxIn, TxOut CtxUTxO Era)]
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 Era)
Commit.deserializeCommit Network
network) [Commit]
onChainDeposits
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
depositValue Value -> Value -> Bool
`containsValue` (TxOut CtxUTxO Era -> Value) -> UTxO -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue UTxO
depositedUTxO
    UTxO -> Maybe UTxO
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
depositedUTxO
  (HeadId, UTxO, POSIXTime) -> Maybe (HeadId, UTxO, POSIXTime)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadId
headId, UTxO
deposit, POSIXTime
deadline)
 where
  depositValue :: Value
depositValue = TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
depositOut