module Hydra.Tx.Init where

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

import Data.ByteString qualified as BS
import GHC.IsList (toList)
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokens qualified as HeadTokens
import Hydra.Contract.MintAction (MintAction (..))
import Hydra.Ledger.Cardano.Builder (addTxInsSpending, mintTokens, unsafeBuildTransaction)
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.ContestationPeriod qualified as ContestationPeriod
import Hydra.Tx.DepositPeriod qualified as DepositPeriod
import Hydra.Tx.HeadId (HeadId, HeadSeed, mkHeadId, txInToHeadSeed)
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.OnChainId (OnChainId (..))
import Hydra.Tx.Party (partyFromChain, partyToChain)
import Hydra.Tx.Utils (assetNameToOnChainId, findFirst, hydraHeadV2AssetName, mkHydraHeadV2TxName, onChainIdToAssetName)
import PlutusLedgerApi.Common (FromData, toBuiltin)
import PlutusLedgerApi.V3 (POSIXTime (..), PubKeyHash (..))

-- * Construction

-- | Create the init transaction from some 'HeadParameters' and a single TxIn
-- which will be used as unique parameter for minting NFTs.
initTx ::
  NetworkId ->
  -- | Current protocol parameters, used to compute worst-case min-UTxO.
  PParams LedgerEra ->
  -- | Seed input.
  TxIn ->
  -- | Verification key hashes of all participants.
  [OnChainId] ->
  HeadParameters ->
  Tx
initTx :: NetworkId
-> PParams LedgerEra -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initTx NetworkId
networkId PParams LedgerEra
pparams TxIn
seedTxIn [OnChainId]
participants HeadParameters
parameters =
  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
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addTxInsSpending [TxIn
seedTxIn]
      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
openHeadOutput]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& PlutusScript
-> MintAction
-> PolicyAssets
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> PolicyAssets
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
mintTokens (TxIn -> PlutusScript
HeadTokens.mkHeadTokenScript TxIn
seedTxIn) MintAction
Mint ([Item PolicyAssets] -> PolicyAssets
forall l. IsList l => [Item l] -> l
fromList ([Item PolicyAssets] -> PolicyAssets)
-> [Item PolicyAssets] -> PolicyAssets
forall a b. (a -> b) -> a -> b
$ (AssetName
hydraHeadV2AssetName, Quantity
1) (AssetName, Quantity)
-> [(AssetName, Quantity)] -> [(AssetName, Quantity)]
forall a. a -> [a] -> [a]
: [(AssetName, Quantity)]
participationTokens)
      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
"InitTx")
 where
  participationTokens :: [(AssetName, Quantity)]
participationTokens =
    [(OnChainId -> AssetName
onChainIdToAssetName OnChainId
oid, Quantity
1) | OnChainId
oid <- [OnChainId]
participants]

  -- Set head output ADA to cover the worst-case min-UTxO: a ClosedDatum with
  -- N contesters (all parties contest, the maximum the datum can grow to).
  -- This ensures the wallet never needs to bump the head value at Close or
  -- Contest time, which would violate the strict equality check on-chain.
  openHeadOutput :: TxOut CtxTx Era
openHeadOutput =
    (Value -> Value) -> TxOut CtxTx Era -> TxOut CtxTx Era
forall era ctx.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value
worstCaseMinLovelace <>) (TxOut CtxTx Era -> TxOut CtxTx Era)
-> TxOut CtxTx Era -> TxOut CtxTx Era
forall a b. (a -> b) -> a -> b
$
      NetworkId
-> PolicyId -> [OnChainId] -> TxOutDatum CtxTx -> TxOut CtxTx Era
forall ctx.
NetworkId -> PolicyId -> [OnChainId] -> TxOutDatum ctx -> TxOut ctx
mkHeadOutput NetworkId
networkId PolicyId
tokenPolicyId [OnChainId]
participants TxOutDatum CtxTx
openHeadDatum

  worstCaseMinLovelace :: Value
worstCaseMinLovelace =
    PParams LedgerEra -> TxOut CtxTx Era -> Value
minUTxOValue PParams LedgerEra
pparams (TxOut CtxTx Era -> Value) -> TxOut CtxTx Era -> Value
forall a b. (a -> b) -> a -> b
$
      NetworkId
-> PolicyId -> [OnChainId] -> TxOutDatum CtxTx -> TxOut CtxTx Era
forall ctx.
NetworkId -> PolicyId -> [OnChainId] -> TxOutDatum ctx -> TxOut ctx
mkHeadOutput NetworkId
networkId PolicyId
tokenPolicyId [OnChainId]
participants TxOutDatum CtxTx
worstCaseClosedDatum

  worstCaseClosedDatum :: TxOutDatum CtxTx
worstCaseClosedDatum =
    State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (State -> TxOutDatum CtxTx) -> State -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$
      ClosedDatum -> State
Head.Closed
        Head.ClosedDatum
          { $sel:headId:ClosedDatum :: CurrencySymbol
headId = PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
tokenPolicyId
          , $sel:parties:ClosedDatum :: [Party]
parties = (Party -> Party) -> [Party] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map Party -> Party
partyToChain [Party]
parties
          , $sel:contestationPeriod:ClosedDatum :: ContestationPeriod
contestationPeriod = ContestationPeriod -> ContestationPeriod
ContestationPeriod.toChain ContestationPeriod
contestationPeriod
          , $sel:depositPeriod:ClosedDatum :: DepositPeriod
depositPeriod = DepositPeriod -> DepositPeriod
DepositPeriod.toChain DepositPeriod
depositPeriod
          , $sel:version:ClosedDatum :: SnapshotVersion
version = Word64 -> SnapshotVersion
forall a. Integral a => a -> SnapshotVersion
toInteger (forall a. Bounded a => a
maxBound @Word64)
          , $sel:snapshotNumber:ClosedDatum :: SnapshotVersion
snapshotNumber = Word64 -> SnapshotVersion
forall a. Integral a => a -> SnapshotVersion
toInteger (forall a. Bounded a => a
maxBound @Word64)
          , $sel:contesters:ClosedDatum :: [PubKeyHash]
contesters = Int -> PubKeyHash -> [PubKeyHash]
forall a. Int -> a -> [a]
replicate ([OnChainId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [OnChainId]
participants) (BuiltinByteString -> PubKeyHash
PubKeyHash (BuiltinByteString -> PubKeyHash)
-> BuiltinByteString -> PubKeyHash
forall a b. (a -> b) -> a -> b
$ ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate Int
28 Word8
0)
          , $sel:contestationDeadline:ClosedDatum :: POSIXTime
contestationDeadline = SnapshotVersion -> POSIXTime
POSIXTime (Word64 -> SnapshotVersion
forall a. Integral a => a -> SnapshotVersion
toInteger (forall a. Bounded a => a
maxBound @Word64))
          , $sel:accumulatorCommitment:ClosedDatum :: BuiltinBLS12_381_G1_Element
accumulatorCommitment =
              HydraAccumulator -> BuiltinBLS12_381_G1_Element
Accumulator.getAccumulatorCommitment (HydraAccumulator -> BuiltinBLS12_381_G1_Element)
-> HydraAccumulator -> BuiltinBLS12_381_G1_Element
forall a b. (a -> b) -> a -> b
$
                forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs @Tx UTxO
UTxOType Tx
forall a. Monoid a => a
mempty Maybe UTxO
Maybe (UTxOType Tx)
forall a. Maybe a
Nothing Maybe UTxO
Maybe (UTxOType Tx)
forall a. Maybe a
Nothing
          , $sel:headAdaOverhead:ClosedDatum :: SnapshotVersion
headAdaOverhead = Word64 -> SnapshotVersion
forall a. Integral a => a -> SnapshotVersion
toInteger (forall a. Bounded a => a
maxBound @Word64)
          }

  tokenPolicyId :: PolicyId
tokenPolicyId = TxIn -> PolicyId
HeadTokens.headPolicyId TxIn
seedTxIn

  openHeadDatum :: TxOutDatum CtxTx
openHeadDatum =
    State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (State -> TxOutDatum CtxTx) -> State -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$
      OpenDatum -> State
Head.Open
        Head.OpenDatum
          { $sel:headSeed:OpenDatum :: TxOutRef
headSeed = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
seedTxIn
          , $sel:headId:OpenDatum :: CurrencySymbol
headId = PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
tokenPolicyId
          , $sel:parties:OpenDatum :: [Party]
parties = (Party -> Party) -> [Party] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map Party -> Party
partyToChain [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:version:OpenDatum :: SnapshotVersion
version = SnapshotVersion
0
          , $sel:accumulatorHash:OpenDatum :: BuiltinByteString
accumulatorHash = 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 -> ByteString) -> HydraAccumulator -> ByteString
forall a b. (a -> b) -> a -> b
$ forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs @Tx UTxO
UTxOType Tx
forall a. Monoid a => a
mempty Maybe UTxO
Maybe (UTxOType Tx)
forall a. Maybe a
Nothing Maybe UTxO
Maybe (UTxOType Tx)
forall a. Maybe a
Nothing
          , $sel:headAdaOverhead:OpenDatum :: SnapshotVersion
headAdaOverhead = let Coin SnapshotVersion
n = Value -> Coin
selectLovelace Value
worstCaseMinLovelace in SnapshotVersion
n
          }

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

mkHeadOutput :: NetworkId -> PolicyId -> [OnChainId] -> TxOutDatum ctx -> TxOut ctx
mkHeadOutput :: forall ctx.
NetworkId -> PolicyId -> [OnChainId] -> TxOutDatum ctx -> TxOut ctx
mkHeadOutput NetworkId
networkId PolicyId
tokenPolicyId [OnChainId]
participants TxOutDatum ctx
datum =
  AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
    (NetworkId -> PlutusScript -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript
Head.validatorScript)
    ([Item Value] -> Value
forall l. IsList l => [Item l] -> l
fromList ([Item Value] -> Value) -> [Item Value] -> Value
forall a b. (a -> b) -> a -> b
$ (AssetId, Quantity)
st (AssetId, Quantity)
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a. a -> [a] -> [a]
: [(AssetId, Quantity)]
pts)
    TxOutDatum ctx
datum
    ReferenceScript
ReferenceScriptNone
 where
  st :: (AssetId, Quantity)
st = (PolicyId -> AssetName -> AssetId
AssetId PolicyId
tokenPolicyId AssetName
hydraHeadV2AssetName, Quantity
1)

  pts :: [(AssetId, Quantity)]
pts =
    [ (PolicyId -> AssetName -> AssetId
AssetId PolicyId
tokenPolicyId AssetName
an, Quantity
1)
    | OnChainId
oid <- [OnChainId]
participants
    , let an :: AssetName
an = OnChainId -> AssetName
onChainIdToAssetName OnChainId
oid
    ]

-- * Observation

-- | Data which can be observed from an `initTx`.
data InitObservation = InitObservation
  { InitObservation -> HeadId
headId :: HeadId
  , InitObservation -> HeadSeed
headSeed :: HeadSeed
  , InitObservation -> HeadParameters
headParameters :: HeadParameters
  , InitObservation -> [OnChainId]
participants :: [OnChainId]
  }
  deriving stock (Int -> InitObservation -> ShowS
[InitObservation] -> ShowS
InitObservation -> String
(Int -> InitObservation -> ShowS)
-> (InitObservation -> String)
-> ([InitObservation] -> ShowS)
-> Show InitObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitObservation -> ShowS
showsPrec :: Int -> InitObservation -> ShowS
$cshow :: InitObservation -> String
show :: InitObservation -> String
$cshowList :: [InitObservation] -> ShowS
showList :: [InitObservation] -> ShowS
Show, InitObservation -> InitObservation -> Bool
(InitObservation -> InitObservation -> Bool)
-> (InitObservation -> InitObservation -> Bool)
-> Eq InitObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InitObservation -> InitObservation -> Bool
== :: InitObservation -> InitObservation -> Bool
$c/= :: InitObservation -> InitObservation -> Bool
/= :: InitObservation -> InitObservation -> Bool
Eq, (forall x. InitObservation -> Rep InitObservation x)
-> (forall x. Rep InitObservation x -> InitObservation)
-> Generic InitObservation
forall x. Rep InitObservation x -> InitObservation
forall x. InitObservation -> Rep InitObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InitObservation -> Rep InitObservation x
from :: forall x. InitObservation -> Rep InitObservation x
$cto :: forall x. Rep InitObservation x -> InitObservation
to :: forall x. Rep InitObservation x -> InitObservation
Generic)
  deriving anyclass ([InitObservation] -> Value
[InitObservation] -> Encoding
InitObservation -> Bool
InitObservation -> Value
InitObservation -> Encoding
(InitObservation -> Value)
-> (InitObservation -> Encoding)
-> ([InitObservation] -> Value)
-> ([InitObservation] -> Encoding)
-> (InitObservation -> Bool)
-> ToJSON InitObservation
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: InitObservation -> Value
toJSON :: InitObservation -> Value
$ctoEncoding :: InitObservation -> Encoding
toEncoding :: InitObservation -> Encoding
$ctoJSONList :: [InitObservation] -> Value
toJSONList :: [InitObservation] -> Value
$ctoEncodingList :: [InitObservation] -> Encoding
toEncodingList :: [InitObservation] -> Encoding
$comitField :: InitObservation -> Bool
omitField :: InitObservation -> Bool
ToJSON, Maybe InitObservation
Value -> Parser [InitObservation]
Value -> Parser InitObservation
(Value -> Parser InitObservation)
-> (Value -> Parser [InitObservation])
-> Maybe InitObservation
-> FromJSON InitObservation
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser InitObservation
parseJSON :: Value -> Parser InitObservation
$cparseJSONList :: Value -> Parser [InitObservation]
parseJSONList :: Value -> Parser [InitObservation]
$comittedField :: Maybe InitObservation
omittedField :: Maybe InitObservation
FromJSON)

data NotAnInitReason
  = NoHeadOutput
  | NotAHeadDatum
  | InvalidPartyInDatum
  | NoSTFound
  | NotAHeadPolicy
  | NoTokensMinted
  deriving stock (Int -> NotAnInitReason -> ShowS
[NotAnInitReason] -> ShowS
NotAnInitReason -> String
(Int -> NotAnInitReason -> ShowS)
-> (NotAnInitReason -> String)
-> ([NotAnInitReason] -> ShowS)
-> Show NotAnInitReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotAnInitReason -> ShowS
showsPrec :: Int -> NotAnInitReason -> ShowS
$cshow :: NotAnInitReason -> String
show :: NotAnInitReason -> String
$cshowList :: [NotAnInitReason] -> ShowS
showList :: [NotAnInitReason] -> ShowS
Show, NotAnInitReason -> NotAnInitReason -> Bool
(NotAnInitReason -> NotAnInitReason -> Bool)
-> (NotAnInitReason -> NotAnInitReason -> Bool)
-> Eq NotAnInitReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotAnInitReason -> NotAnInitReason -> Bool
== :: NotAnInitReason -> NotAnInitReason -> Bool
$c/= :: NotAnInitReason -> NotAnInitReason -> Bool
/= :: NotAnInitReason -> NotAnInitReason -> Bool
Eq, (forall x. NotAnInitReason -> Rep NotAnInitReason x)
-> (forall x. Rep NotAnInitReason x -> NotAnInitReason)
-> Generic NotAnInitReason
forall x. Rep NotAnInitReason x -> NotAnInitReason
forall x. NotAnInitReason -> Rep NotAnInitReason x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NotAnInitReason -> Rep NotAnInitReason x
from :: forall x. NotAnInitReason -> Rep NotAnInitReason x
$cto :: forall x. Rep NotAnInitReason x -> NotAnInitReason
to :: forall x. Rep NotAnInitReason x -> NotAnInitReason
Generic)

-- | Identify a init tx by checking the output value for holding tokens that are
-- valid head tokens (checked by seed + policy).
observeInitTx ::
  Tx ->
  Either NotAnInitReason InitObservation
observeInitTx :: Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx = do
  (TxOut CtxTx Era
headOut, State
headState) <-
    (TxOut CtxTx Era -> Maybe (TxOut CtxTx Era, State))
-> [TxOut CtxTx Era] -> Maybe (TxOut CtxTx Era, State)
forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst TxOut CtxTx Era -> Maybe (TxOut CtxTx Era, State)
forall a.
FromData a =>
TxOut CtxTx Era -> Maybe (TxOut CtxTx Era, a)
matchHeadOutput (Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx) Maybe (TxOut CtxTx Era, State)
-> NotAnInitReason
-> Either NotAnInitReason (TxOut CtxTx Era, State)
forall a e. Maybe a -> e -> Either e a
?> NotAnInitReason
NoHeadOutput

  -- check that we have a proper head
  (PolicyId
pid, ContestationPeriod
contestationPeriod, DepositPeriod
depositPeriod, [Party]
onChainParties, TxIn
seedTxIn) <- case State
headState of
    Head.Open Head.OpenDatum{TxOutRef
$sel:headSeed:OpenDatum :: OpenDatum -> TxOutRef
headSeed :: TxOutRef
headSeed, CurrencySymbol
$sel:headId:OpenDatum :: OpenDatum -> CurrencySymbol
headId :: CurrencySymbol
headId, [Party]
$sel:parties:OpenDatum :: OpenDatum -> [Party]
parties :: [Party]
parties, ContestationPeriod
$sel:contestationPeriod:OpenDatum :: OpenDatum -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:OpenDatum :: OpenDatum -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod} -> do
      PolicyId
pid <- CurrencySymbol -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m PolicyId
fromPlutusCurrencySymbol CurrencySymbol
headId Maybe PolicyId
-> NotAnInitReason -> Either NotAnInitReason PolicyId
forall a e. Maybe a -> e -> Either e a
?> NotAnInitReason
NotAHeadPolicy
      (PolicyId, ContestationPeriod, DepositPeriod, [Party], TxIn)
-> Either
     NotAnInitReason
     (PolicyId, ContestationPeriod, DepositPeriod, [Party], TxIn)
forall a. a -> Either NotAnInitReason a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PolicyId
pid, ContestationPeriod -> ContestationPeriod
ContestationPeriod.fromChain ContestationPeriod
contestationPeriod, DepositPeriod -> DepositPeriod
DepositPeriod.fromChain DepositPeriod
depositPeriod, [Party]
parties, TxOutRef -> TxIn
fromPlutusTxOutRef TxOutRef
headSeed)
    State
_ -> NotAnInitReason
-> Either
     NotAnInitReason
     (PolicyId, ContestationPeriod, DepositPeriod, [Party], TxIn)
forall a b. a -> Either a b
Left NotAnInitReason
NotAHeadDatum

  -- Check minted value to distinguish from increment/decrement
  let mintedValue :: Value
mintedValue = TxMintValue ViewTx Era -> Value
forall build era. TxMintValue build era -> Value
txMintValueToValue (TxMintValue ViewTx Era -> Value)
-> (TxBody Era -> TxMintValue ViewTx Era) -> TxBody Era -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyContent ViewTx -> TxMintValue ViewTx Era
forall build. TxBodyContent build -> TxMintValue build
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx Era)
-> (TxBody Era -> TxBodyContent ViewTx)
-> TxBody Era
-> TxMintValue ViewTx Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody Era -> TxBodyContent ViewTx
forall era. TxBody era -> TxBodyContent ViewTx era
getTxBodyContent (TxBody Era -> Value) -> TxBody Era -> Value
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx
      stAssetId :: AssetId
stAssetId = PolicyId -> AssetName -> AssetId
AssetId PolicyId
pid AssetName
hydraHeadV2AssetName
  Bool -> Either NotAnInitReason () -> Either NotAnInitReason ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value -> AssetId -> Quantity
selectAsset Value
mintedValue AssetId
stAssetId Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1) (Either NotAnInitReason () -> Either NotAnInitReason ())
-> Either NotAnInitReason () -> Either NotAnInitReason ()
forall a b. (a -> b) -> a -> b
$
    NotAnInitReason -> Either NotAnInitReason ()
forall a b. a -> Either a b
Left NotAnInitReason
NoTokensMinted

  -- check that ST is present in the head output
  Bool -> Either NotAnInitReason () -> Either NotAnInitReason ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value -> AssetId -> Quantity
selectAsset (TxOut CtxTx Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxTx Era
headOut) AssetId
stAssetId Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1) (Either NotAnInitReason () -> Either NotAnInitReason ())
-> Either NotAnInitReason () -> Either NotAnInitReason ()
forall a b. (a -> b) -> a -> b
$
    NotAnInitReason -> Either NotAnInitReason ()
forall a b. a -> Either a b
Left NotAnInitReason
NoSTFound

  -- check that we are using the same seed and headId matches
  Bool -> Either NotAnInitReason () -> Either NotAnInitReason ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn -> PolicyId
HeadTokens.headPolicyId TxIn
seedTxIn) (Either NotAnInitReason () -> Either NotAnInitReason ())
-> Either NotAnInitReason () -> Either NotAnInitReason ()
forall a b. (a -> b) -> a -> b
$
    NotAnInitReason -> Either NotAnInitReason ()
forall a b. a -> Either a b
Left NotAnInitReason
NotAHeadPolicy

  [Party]
parties <-
    Either NotAnInitReason [Party]
-> ([Party] -> Either NotAnInitReason [Party])
-> Maybe [Party]
-> Either NotAnInitReason [Party]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotAnInitReason -> Either NotAnInitReason [Party]
forall a b. a -> Either a b
Left NotAnInitReason
InvalidPartyInDatum) [Party] -> Either NotAnInitReason [Party]
forall a b. b -> Either a b
Right (Maybe [Party] -> Either NotAnInitReason [Party])
-> Maybe [Party] -> Either NotAnInitReason [Party]
forall a b. (a -> b) -> a -> b
$
      (Party -> Maybe Party) -> [Party] -> Maybe [Party]
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 Party -> Maybe Party
forall (m :: * -> *). MonadFail m => Party -> m Party
partyFromChain [Party]
onChainParties

  InitObservation -> Either NotAnInitReason InitObservation
forall a. a -> Either NotAnInitReason a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InitObservation -> Either NotAnInitReason InitObservation)
-> InitObservation -> Either NotAnInitReason InitObservation
forall a b. (a -> b) -> a -> b
$
    InitObservation
      { $sel:headId:InitObservation :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
pid
      , $sel:headSeed:InitObservation :: HeadSeed
headSeed = TxIn -> HeadSeed
txInToHeadSeed TxIn
seedTxIn
      , $sel:headParameters:InitObservation :: HeadParameters
headParameters = HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:HeadParameters :: DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, [Party]
$sel:parties:HeadParameters :: [Party]
parties :: [Party]
parties}
      , $sel:participants:InitObservation :: [OnChainId]
participants = AssetName -> OnChainId
assetNameToOnChainId (AssetName -> OnChainId) -> [AssetName] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PolicyId -> [AssetName]
mintedTokenNames PolicyId
pid
      }
 where
  matchHeadOutput :: FromData a => TxOut CtxTx -> Maybe (TxOut CtxTx, a)
  matchHeadOutput :: forall a.
FromData a =>
TxOut CtxTx Era -> Maybe (TxOut CtxTx Era, a)
matchHeadOutput TxOut CtxTx Era
out = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ PlutusScript -> TxOut CtxTx Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript
Head.validatorScript TxOut CtxTx Era
out
    (TxOut CtxTx Era
out,) (a -> (TxOut CtxTx Era, a))
-> Maybe a -> Maybe (TxOut CtxTx Era, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HashableScriptData -> Maybe a
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData (HashableScriptData -> Maybe a)
-> Maybe HashableScriptData -> Maybe a
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 CtxTx Era
out)

  mintedTokenNames :: PolicyId -> [AssetName]
mintedTokenNames PolicyId
pid =
    [ AssetName
assetName
    | (AssetId PolicyId
policyId AssetName
assetName, Quantity
q) <- Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList (Value -> [Item Value]) -> Value -> [Item Value]
forall a b. (a -> b) -> a -> b
$ TxMintValue ViewTx Era -> Value
forall build era. TxMintValue build era -> Value
txMintValueToValue (TxMintValue ViewTx Era -> Value)
-> TxMintValue ViewTx Era -> Value
forall a b. (a -> b) -> a -> b
$ TxBodyContent ViewTx -> TxMintValue ViewTx Era
forall build. TxBodyContent build -> TxMintValue build
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx Era)
-> TxBodyContent ViewTx -> TxMintValue ViewTx Era
forall a b. (a -> b) -> a -> b
$ TxBody Era -> TxBodyContent ViewTx
forall era. TxBody era -> TxBodyContent ViewTx era
getTxBodyContent (TxBody Era -> TxBodyContent ViewTx)
-> TxBody Era -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx
    , Quantity
q Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1 -- NOTE: Only consider unique tokens
    , PolicyId
policyId PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
pid
    , AssetName
assetName AssetName -> AssetName -> Bool
forall a. Eq a => a -> a -> Bool
/= AssetName
hydraHeadV2AssetName
    ]