{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

{- |
Module      : Singular.Registry.Replay
Description : A registry's trie rebuilt from the public history of its state token
License     : Apache-2.0

The chain commits a registry's trie by its root only. This module rebuilds
the trie itself from the transactions that moved the registry's state
token since @create@, so a reader needs nobody's local copy.

The lineage is chained by spends, never by the order the transactions are
given in: @create@ mints the token under @Minting(seed)@, and each fold
spends the previous state output. A transaction whose bytes say it failed
its scripts (@isValid = false@) spent only its collateral and is never in
the lineage, whatever its body's inputs name. Every fold applies its
requests the way the state validator does
(@onchain\/validators\/registry\/fold.ak@): the spending inputs in ledger
order, an inline 'RequestDatum' naming this registry's token takes the
next action of the state input's @Modify@ redeemer, 'Rejected' leaves the
trie as it is and 'Update' walks the request's edge with 'walkEdge'. After
every fold the rebuilt root must equal the root in that fold's state datum.

The answer is the trie rebuilt into the caller's 'Trie', or one named
'TrieFailure'. On a refusal the caller's trie holds a partial replay and must
be discarded.
-}
module Singular.Registry.Replay
    ( replayLineage
    , Replayed (..)
    , appliedKeys
    , replayedLineage
    ) where

import Control.Monad (foldM, forM_, unless, void, when)
import Data.ByteString (ByteString)
import Data.ByteString.Short qualified as SBS
import Data.Foldable (toList)
import Data.List qualified as List
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Lens.Micro ((^.))

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Alonzo.Scripts (AsIx (..))
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.Api.Scripts.Data (getPlutusData)
import Cardano.Ledger.Api.Tx (bodyTxL, isValidTxL, txIdTx, witsTxL)
import Cardano.Ledger.Api.Tx.Body
    ( inputsTxBodyL
    , mintTxBodyL
    , outputsTxBodyL
    )
import Cardano.Ledger.Api.Tx.Out (TxOut, addrTxOutL, valueTxOutL)
import Cardano.Ledger.Api.Tx.Wits (rdmrsTxWitsL)
import Cardano.Ledger.BaseTypes (TxIx (..))
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Mary.Value
    ( AssetName (..)
    , MaryValue (..)
    , MultiAsset (..)
    , PolicyID (..)
    )
import Cardano.Ledger.TxIn (TxId, TxIn (..))
import Cardano.Tx.Ledger (ConwayTx)
import PlutusTx (FromData (..))
import PlutusTx.Builtins.Internal
    ( BuiltinByteString (..)
    , BuiltinData (..)
    )

import Singular.Registry.AssetName (deriveAssetName)
import Singular.Registry.Ledger (ConwayEra, Root (..))
import Singular.Registry.Trie (Trie (..))
import Singular.Registry.TrieState
    ( Incomplete (..)
    , Mismatch (..)
    , Parting (..)
    , PublicLineage (..)
    , RegistryIdentity (..)
    , Staleness (..)
    , StatePolicyId (..)
    , TrieFailure (..)
    , Undecodable (..)
    )
import Singular.Registry.TxBuilder.Internal
    ( emptyRoot
    , extractCageDatum
    , scriptHashBytes
    , txInToRef
    , walkEdge
    )
import Singular.Registry.Types
    ( CageDatum (..)
    , MintRedeemer (..)
    , OnChainRequest (..)
    , OnChainRoot (..)
    , OnChainTokenId (..)
    , OnChainTokenState (..)
    , RequestAction (..)
    , UpdateRedeemer (..)
    )

-- | A replay that reached the selected state output from @create@.
data Replayed = Replayed
    { Replayed -> TxId
replayedCreate :: TxId
    -- ^ The transaction that minted the state token
    , Replayed -> [TxId]
replayedFolds :: [TxId]
    -- ^ Every fold from @create@ to the selected output, in chain order
    , Replayed -> [ByteString]
replayedKeys :: [ByteString]
    -- ^ The distinct keys the applied updates named, ascending
    }
    deriving stock (Replayed -> Replayed -> Bool
(Replayed -> Replayed -> Bool)
-> (Replayed -> Replayed -> Bool) -> Eq Replayed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Replayed -> Replayed -> Bool
== :: Replayed -> Replayed -> Bool
$c/= :: Replayed -> Replayed -> Bool
/= :: Replayed -> Replayed -> Bool
Eq, Int -> Replayed -> ShowS
[Replayed] -> ShowS
Replayed -> String
(Int -> Replayed -> ShowS)
-> (Replayed -> String) -> ([Replayed] -> ShowS) -> Show Replayed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Replayed -> ShowS
showsPrec :: Int -> Replayed -> ShowS
$cshow :: Replayed -> String
show :: Replayed -> String
$cshowList :: [Replayed] -> ShowS
showList :: [Replayed] -> ShowS
Show)

{- | The distinct keys applied updates named, ascending. Rejected requests
are not applied and name nothing here.
-}
appliedKeys :: [(OnChainRequest, RequestAction)] -> [ByteString]
appliedKeys :: [(OnChainRequest, RequestAction)] -> [ByteString]
appliedKeys [(OnChainRequest, RequestAction)]
pairs =
    [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
List.sort
        ( Set ByteString -> [ByteString]
forall a. Set a -> [a]
Set.toList
            ([ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList [OnChainRequest -> ByteString
requestKey OnChainRequest
r | (OnChainRequest
r, Update [ProofStep]
_) <- [(OnChainRequest, RequestAction)]
pairs])
        )

{- | A replay as its public lineage: the create, the folds in chain order
and the distinct keys the applied updates named.
-}
replayedLineage :: Replayed -> PublicLineage
replayedLineage :: Replayed -> PublicLineage
replayedLineage Replayed{TxId
replayedCreate :: Replayed -> TxId
replayedCreate :: TxId
replayedCreate, [TxId]
replayedFolds :: Replayed -> [TxId]
replayedFolds :: [TxId]
replayedFolds, [ByteString]
replayedKeys :: Replayed -> [ByteString]
replayedKeys :: [ByteString]
replayedKeys} =
    TxId -> [TxId] -> [ByteString] -> PublicLineage
PublicLineage TxId
replayedCreate [TxId]
replayedFolds [ByteString]
replayedKeys

{- | Rebuild the registry's trie into the given trie, from the history of its
state token up to the selected state output.

The history is the ledger's own transactions, in any order; a transaction
whose bytes say it failed its scripts (@isValid = false@) is left out before
anything else reads the history, since it spent only its collateral. The
map resolves every input they spend or reference. The selection is a state
output and the root the caller expects there.
-}
replayLineage
    :: (Monad m)
    => Trie m
    -- ^ An empty trie the replay fills
    -> RegistryIdentity
    -> TxIn
    -- ^ The selected state output
    -> Root
    -- ^ The root the selection expects at that output
    -> Map TxIn (TxOut ConwayEra)
    -- ^ Resolved spent and reference outputs
    -> [ConwayTx]
    -- ^ The state token's history
    -> m (Either TrieFailure Replayed)
replayLineage :: forall (m :: * -> *).
Monad m =>
Trie m
-> RegistryIdentity
-> TxIn
-> Root
-> Map TxIn (TxOut ConwayEra)
-> [Tx TopTx ConwayEra]
-> m (Either TrieFailure Replayed)
replayLineage Trie m
trie RegistryIdentity
token TxIn
selected Root
selection Map TxIn (TxOut ConwayEra)
resolved [Tx TopTx ConwayEra]
history =
    case RegistryIdentity
-> TxIn
-> Root
-> Map TxIn (TxOut ConwayEra)
-> [Tx TopTx ConwayEra]
-> Either TrieFailure Lineage
lineageOf RegistryIdentity
token TxIn
selected Root
selection Map TxIn (TxOut ConwayEra)
resolved [Tx TopTx ConwayEra]
history of
        Left TrieFailure
failure -> Either TrieFailure Replayed -> m (Either TrieFailure Replayed)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TrieFailure -> Either TrieFailure Replayed
forall a b. a -> Either a b
Left TrieFailure
failure)
        Right Lineage
lineage -> Trie m
-> RegistryIdentity -> Lineage -> m (Either TrieFailure Replayed)
forall (m :: * -> *).
Monad m =>
Trie m
-> RegistryIdentity -> Lineage -> m (Either TrieFailure Replayed)
replayFolds Trie m
trie RegistryIdentity
token Lineage
lineage

-- ---------------------------------------------------------
-- The lineage, from the selection back to create
-- ---------------------------------------------------------

-- | The chain from @create@ to the selected state output.
data Lineage = Lineage
    { Lineage -> TxId
lineageCreate :: TxId
    , Lineage -> Root
lineageCreateRoot :: Root
    , Lineage -> [Fold]
lineageFolds :: [Fold]
    -- ^ In chain order
    , Lineage -> TxIn -> Either Incomplete (TxOut ConwayEra)
lineageResolve :: TxIn -> Either Incomplete (TxOut ConwayEra)
    }

-- | One fold of the lineage: the transaction, the state output it spends and the root it records.
data Fold = Fold
    { Fold -> TxId
foldId :: TxId
    , Fold -> Tx TopTx ConwayEra
foldTx :: ConwayTx
    , Fold -> TxIn
foldStateInput :: TxIn
    , Fold -> Root
foldRoot :: Root
    }

{- | Chain the history by spends from the selected output back to @create@,
then refuse a history that forks a state output, touches the token outside
the lineage, or a selection whose root is not the one at its output.
-}
lineageOf
    :: RegistryIdentity
    -> TxIn
    -> Root
    -> Map TxIn (TxOut ConwayEra)
    -> [ConwayTx]
    -> Either TrieFailure Lineage
lineageOf :: RegistryIdentity
-> TxIn
-> Root
-> Map TxIn (TxOut ConwayEra)
-> [Tx TopTx ConwayEra]
-> Either TrieFailure Lineage
lineageOf RegistryIdentity
token selected :: TxIn
selected@(TxIn TxId
selectedId TxIx
selectedIx) Root
selection Map TxIn (TxOut ConwayEra)
resolved [Tx TopTx ConwayEra]
history = do
    byId <- RegistryIdentity
-> [Tx TopTx ConwayEra]
-> Either TrieFailure (Map TxId (Tx TopTx ConwayEra))
distinct RegistryIdentity
token ((Tx TopTx ConwayEra -> Bool)
-> [Tx TopTx ConwayEra] -> [Tx TopTx ConwayEra]
forall a. (a -> Bool) -> [a] -> [a]
filter Tx TopTx ConwayEra -> Bool
passedScripts [Tx TopTx ConwayEra]
history)
    let refuse = RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
forall a.
RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
failWith RegistryIdentity
token
        produced i :: TxIn
i@(TxIn TxId
tid TxIx
ix) =
            TxId -> Map TxId (Tx TopTx ConwayEra) -> Maybe (Tx TopTx ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxId
tid Map TxId (Tx TopTx ConwayEra)
byId Maybe (Tx TopTx ConwayEra)
-> (Tx TopTx ConwayEra -> Maybe (TxIn, BabbageTxOut ConwayEra))
-> Maybe (TxIn, BabbageTxOut ConwayEra)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx TopTx ConwayEra
tx -> Tx TopTx ConwayEra -> TxIx -> Maybe (TxOut ConwayEra)
outputAt Tx TopTx ConwayEra
tx TxIx
ix Maybe (BabbageTxOut ConwayEra)
-> (BabbageTxOut ConwayEra -> Maybe (TxIn, BabbageTxOut ConwayEra))
-> Maybe (TxIn, BabbageTxOut ConwayEra)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BabbageTxOut ConwayEra
o -> (TxIn, BabbageTxOut ConwayEra)
-> Maybe (TxIn, BabbageTxOut ConwayEra)
forall a. a -> Maybe a
Just (TxIn
i, BabbageTxOut ConwayEra
o)
        resolve TxIn
i = case (TxIn -> Maybe (TxIn, BabbageTxOut ConwayEra)
produced TxIn
i, TxIn
-> Map TxIn (BabbageTxOut ConwayEra)
-> Maybe (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
i Map TxIn (TxOut ConwayEra)
Map TxIn (BabbageTxOut ConwayEra)
resolved) of
            (Just (TxIn
_, BabbageTxOut ConwayEra
o), Just BabbageTxOut ConwayEra
o')
                | BabbageTxOut ConwayEra
o BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra -> Bool
forall a. Eq a => a -> a -> Bool
/= BabbageTxOut ConwayEra
o' -> Incomplete -> Either Incomplete (BabbageTxOut ConwayEra)
forall a b. a -> Either a b
Left (TxIn -> Incomplete
ConflictingResolution TxIn
i)
            (Just (TxIn
_, BabbageTxOut ConwayEra
o), Maybe (BabbageTxOut ConwayEra)
_) -> BabbageTxOut ConwayEra
-> Either Incomplete (BabbageTxOut ConwayEra)
forall a b. b -> Either a b
Right BabbageTxOut ConwayEra
o
            (Maybe (TxIn, BabbageTxOut ConwayEra)
Nothing, Just BabbageTxOut ConwayEra
o) -> BabbageTxOut ConwayEra
-> Either Incomplete (BabbageTxOut ConwayEra)
forall a b. b -> Either a b
Right BabbageTxOut ConwayEra
o
            (Maybe (TxIn, BabbageTxOut ConwayEra)
Nothing, Maybe (BabbageTxOut ConwayEra)
Nothing) -> Incomplete -> Either Incomplete (BabbageTxOut ConwayEra)
forall a b. a -> Either a b
Left (TxIn -> Incomplete
UnresolvedInput TxIn
i)
        holds = RegistryIdentity -> TxOut ConwayEra -> Bool
holdsToken RegistryIdentity
token
        walk Tx TopTx ConwayEra
tx TxId
tid [Fold]
folds
            | RegistryIdentity -> Tx TopTx ConwayEra -> Bool
mintsToken RegistryIdentity
token Tx TopTx ConwayEra
tx = do
                createRoot <- RegistryIdentity
-> TxId -> Tx TopTx ConwayEra -> Either TrieFailure Root
checkCreate RegistryIdentity
token TxId
tid Tx TopTx ConwayEra
tx
                pure (tid, createRoot, folds)
            | Bool
otherwise = do
                spent <-
                    (TxIn -> Either TrieFailure (TxIn, BabbageTxOut ConwayEra))
-> [TxIn] -> Either TrieFailure [(TxIn, BabbageTxOut ConwayEra)]
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
                        ( \TxIn
i ->
                            (Incomplete -> Either TrieFailure (TxIn, BabbageTxOut ConwayEra))
-> (BabbageTxOut ConwayEra
    -> Either TrieFailure (TxIn, BabbageTxOut ConwayEra))
-> Either Incomplete (BabbageTxOut ConwayEra)
-> Either TrieFailure (TxIn, BabbageTxOut ConwayEra)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                                (TxId -> Refuse -> Either TrieFailure (TxIn, BabbageTxOut ConwayEra)
forall {a}. TxId -> Refuse -> Either TrieFailure a
refuse TxId
tid (Refuse -> Either TrieFailure (TxIn, BabbageTxOut ConwayEra))
-> (Incomplete -> Refuse)
-> Incomplete
-> Either TrieFailure (TxIn, BabbageTxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure)
-> Incomplete -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete)
                                ((TxIn, BabbageTxOut ConwayEra)
-> Either TrieFailure (TxIn, BabbageTxOut ConwayEra)
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxIn, BabbageTxOut ConwayEra)
 -> Either TrieFailure (TxIn, BabbageTxOut ConwayEra))
-> (BabbageTxOut ConwayEra -> (TxIn, BabbageTxOut ConwayEra))
-> BabbageTxOut ConwayEra
-> Either TrieFailure (TxIn, BabbageTxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn
i,))
                                (TxIn -> Either Incomplete (BabbageTxOut ConwayEra)
resolve TxIn
i)
                        )
                        (Tx TopTx ConwayEra -> [TxIn]
spendingInputs Tx TopTx ConwayEra
tx)
                root <- stateRootOf token tid tx
                case [i | (i, o) <- spent, holds o] of
                    [stateIn :: TxIn
stateIn@(TxIn TxId
previousId TxIx
_)] -> do
                        previous <-
                            Either TrieFailure (Tx TopTx ConwayEra)
-> (Tx TopTx ConwayEra -> Either TrieFailure (Tx TopTx ConwayEra))
-> Maybe (Tx TopTx ConwayEra)
-> Either TrieFailure (Tx TopTx ConwayEra)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                                (TxId -> Refuse -> Either TrieFailure (Tx TopTx ConwayEra)
forall {a}. TxId -> Refuse -> Either TrieFailure a
refuse TxId
previousId ((RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure)
-> Incomplete -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete Incomplete
MissingTransaction))
                                Tx TopTx ConwayEra -> Either TrieFailure (Tx TopTx ConwayEra)
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                (TxId -> Map TxId (Tx TopTx ConwayEra) -> Maybe (Tx TopTx ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxId
previousId Map TxId (Tx TopTx ConwayEra)
byId)
                        unless (stateIn == firstOutput previousId) $
                            refuse previousId (because UndecodableRequest UndecodableStateOutput)
                        walk previous previousId (Fold tid tx stateIn root : folds)
                    [TxIn]
_ -> TxId -> Refuse -> Either TrieFailure (TxId, Root, [Fold])
forall {a}. TxId -> Refuse -> Either TrieFailure a
refuse TxId
tid ((RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure)
-> Incomplete -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete Incomplete
NoStateInput)
    selectedTx <-
        maybe
            (refuse selectedId (because HistoryIncomplete MissingTransaction))
            pure
            (Map.lookup selectedId byId)
    let selectsState =
            TxIx
selectedIx TxIx -> TxIx -> Bool
forall a. Eq a => a -> a -> Bool
== Word16 -> TxIx
TxIx Word16
0
                Bool -> Bool -> Bool
&& Bool
-> (BabbageTxOut ConwayEra -> Bool)
-> Maybe (BabbageTxOut ConwayEra)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False BabbageTxOut ConwayEra -> Bool
holds (Tx TopTx ConwayEra -> TxIx -> Maybe (TxOut ConwayEra)
outputAt Tx TopTx ConwayEra
selectedTx TxIx
selectedIx)
    unless selectsState $
        refuse selectedId (because WrongRegistry SelectionNotState)
    (createId, createRoot, folds) <- walk selectedTx selectedId []
    let chain = TxId
createId TxId -> [TxId] -> [TxId]
forall a. a -> [a] -> [a]
: (Fold -> TxId) -> [Fold] -> [TxId]
forall a b. (a -> b) -> [a] -> [b]
map Fold -> TxId
foldId [Fold]
folds
        spenders = Map TxId (Tx TopTx ConwayEra) -> Map TxIn [TxId]
spentBy Map TxId (Tx TopTx ConwayEra)
byId
        stateOutputs = (TxId -> TxIn) -> [TxId] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map TxId -> TxIn
firstOutput ([TxId] -> [TxId]
forall a. HasCallStack => [a] -> [a]
init [TxId]
chain)
    -- Every state output of the lineage is spent by its next fold only.
    forM_ (zip stateOutputs (drop 1 chain)) $ \(TxIn
output, TxId
next) ->
        case (TxId -> Bool) -> [TxId] -> [TxId]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
/= TxId
next) ([TxId] -> TxIn -> Map TxIn [TxId] -> [TxId]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] TxIn
output Map TxIn [TxId]
spenders) of
            [] -> () -> Either TrieFailure ()
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            TxId
other : [TxId]
_ ->
                TxId -> Refuse -> Either TrieFailure ()
forall {a}. TxId -> Refuse -> Either TrieFailure a
refuse TxId
other ((RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure)
-> Incomplete -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete (TxIn -> Incomplete
ForkedStateOutput TxIn
output))
    -- Past the selection, the history may run ahead along one chain.
    ahead <- descendants refuse spenders byId token selected
    let known = [TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList ([TxId]
chain [TxId] -> [TxId] -> [TxId]
forall a. Semigroup a => a -> a -> a
<> [TxId]
ahead)
        touching TxId
tid Tx TopTx ConwayEra
tx =
            TxId -> Set TxId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember TxId
tid Set TxId
known
                Bool -> Bool -> Bool
&& ( RegistryIdentity -> Tx TopTx ConwayEra -> Bool
mintsToken RegistryIdentity
token Tx TopTx ConwayEra
tx
                        Bool -> Bool -> Bool
|| (BabbageTxOut ConwayEra -> Bool)
-> [BabbageTxOut ConwayEra] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any BabbageTxOut ConwayEra -> Bool
holds (Tx TopTx ConwayEra -> [TxOut ConwayEra]
outputs Tx TopTx ConwayEra
tx)
                        Bool -> Bool -> Bool
|| (TxIn -> Bool) -> [TxIn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Incomplete -> Bool)
-> (BabbageTxOut ConwayEra -> Bool)
-> Either Incomplete (BabbageTxOut ConwayEra)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Incomplete -> Bool
forall a b. a -> b -> a
const Bool
False) BabbageTxOut ConwayEra -> Bool
holds (Either Incomplete (BabbageTxOut ConwayEra) -> Bool)
-> (TxIn -> Either Incomplete (BabbageTxOut ConwayEra))
-> TxIn
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> Either Incomplete (BabbageTxOut ConwayEra)
resolve) (Tx TopTx ConwayEra -> [TxIn]
spendingInputs Tx TopTx ConwayEra
tx)
                   )
    case [tid | (tid, tx) <- Map.toAscList byId, touching tid tx] of
        [] -> () -> Either TrieFailure ()
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        TxId
stray : [TxId]
_ -> TxId -> Refuse -> Either TrieFailure ()
forall {a}. TxId -> Refuse -> Either TrieFailure a
refuse TxId
stray ((RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure)
-> Incomplete -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete Incomplete
OutsideLineage)
    recorded <- stateRootOf token selectedId selectedTx
    when (recorded /= selection) $
        refuse selectedId (because StaleState (StaleRoot selection recorded))
    pure
        Lineage
            { lineageCreate = createId
            , lineageCreateRoot = createRoot
            , lineageFolds = folds
            , lineageResolve = resolve
            }

-- | The history by transaction identifier; two different transactions under one identifier refuse.
distinct
    :: RegistryIdentity
    -> [ConwayTx]
    -> Either TrieFailure (Map TxId ConwayTx)
distinct :: RegistryIdentity
-> [Tx TopTx ConwayEra]
-> Either TrieFailure (Map TxId (Tx TopTx ConwayEra))
distinct RegistryIdentity
token = (Map TxId (Tx TopTx ConwayEra)
 -> Tx TopTx ConwayEra
 -> Either TrieFailure (Map TxId (Tx TopTx ConwayEra)))
-> Map TxId (Tx TopTx ConwayEra)
-> [Tx TopTx ConwayEra]
-> Either TrieFailure (Map TxId (Tx TopTx ConwayEra))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map TxId (Tx TopTx ConwayEra)
-> Tx TopTx ConwayEra
-> Either TrieFailure (Map TxId (Tx TopTx ConwayEra))
forall {era} {l :: TxLevel}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era, Eq (Tx l era)) =>
Map TxId (Tx l era)
-> Tx l era -> Either TrieFailure (Map TxId (Tx l era))
add Map TxId (Tx TopTx ConwayEra)
forall k a. Map k a
Map.empty
  where
    add :: Map TxId (Tx l era)
-> Tx l era -> Either TrieFailure (Map TxId (Tx l era))
add Map TxId (Tx l era)
acc Tx l era
tx =
        let tid :: TxId
tid = Tx l era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx l era
tx
        in  case TxId -> Map TxId (Tx l era) -> Maybe (Tx l era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxId
tid Map TxId (Tx l era)
acc of
                Just Tx l era
seen
                    | Tx l era
seen Tx l era -> Tx l era -> Bool
forall a. Eq a => a -> a -> Bool
/= Tx l era
tx ->
                        RegistryIdentity
-> TxId -> Refuse -> Either TrieFailure (Map TxId (Tx l era))
forall a.
RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
failWith RegistryIdentity
token TxId
tid ((RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure)
-> Incomplete -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete Incomplete
ConflictingCopies)
                Maybe (Tx l era)
_ -> Map TxId (Tx l era) -> Either TrieFailure (Map TxId (Tx l era))
forall a b. b -> Either a b
Right (TxId -> Tx l era -> Map TxId (Tx l era) -> Map TxId (Tx l era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxId
tid Tx l era
tx Map TxId (Tx l era)
acc)

{- | The transactions that continue the chain past the selected output: each
spends the previous state output, one at a time. Two spenders of one output
there refuse, naming the larger identifier: neither is on the lineage.
-}
descendants
    :: (TxId -> Refuse -> Either TrieFailure [TxId])
    -> Map TxIn [TxId]
    -> Map TxId ConwayTx
    -> RegistryIdentity
    -> TxIn
    -> Either TrieFailure [TxId]
descendants :: (TxId -> Refuse -> Either TrieFailure [TxId])
-> Map TxIn [TxId]
-> Map TxId (Tx TopTx ConwayEra)
-> RegistryIdentity
-> TxIn
-> Either TrieFailure [TxId]
descendants TxId -> Refuse -> Either TrieFailure [TxId]
refuse Map TxIn [TxId]
spenders Map TxId (Tx TopTx ConwayEra)
byId RegistryIdentity
token = TxIn -> Either TrieFailure [TxId]
go
  where
    go :: TxIn -> Either TrieFailure [TxId]
go TxIn
output = case [TxId] -> TxIn -> Map TxIn [TxId] -> [TxId]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] TxIn
output Map TxIn [TxId]
spenders of
        [] -> [TxId] -> Either TrieFailure [TxId]
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        [TxId
next] -> case TxId -> Map TxId (Tx TopTx ConwayEra) -> Maybe (Tx TopTx ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxId
next Map TxId (Tx TopTx ConwayEra)
byId of
            Just Tx TopTx ConwayEra
tx
                | Bool
-> (BabbageTxOut ConwayEra -> Bool)
-> Maybe (BabbageTxOut ConwayEra)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (RegistryIdentity -> TxOut ConwayEra -> Bool
holdsToken RegistryIdentity
token) (Tx TopTx ConwayEra -> TxIx -> Maybe (TxOut ConwayEra)
outputAt Tx TopTx ConwayEra
tx (Word16 -> TxIx
TxIx Word16
0)) ->
                    (TxId
next TxId -> [TxId] -> [TxId]
forall a. a -> [a] -> [a]
:) ([TxId] -> [TxId])
-> Either TrieFailure [TxId] -> Either TrieFailure [TxId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxIn -> Either TrieFailure [TxId]
go (TxId -> TxIn
firstOutput TxId
next)
            Maybe (Tx TopTx ConwayEra)
_ -> [TxId] -> Either TrieFailure [TxId]
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TxId
next]
        TxId
_ : TxId
other : [TxId]
_ ->
            TxId -> Refuse -> Either TrieFailure [TxId]
refuse TxId
other ((RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure)
-> Incomplete -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete (TxIn -> Incomplete
ForkedStateOutput TxIn
output))

-- | Which transactions of the history spend each output.
spentBy :: Map TxId ConwayTx -> Map TxIn [TxId]
spentBy :: Map TxId (Tx TopTx ConwayEra) -> Map TxIn [TxId]
spentBy Map TxId (Tx TopTx ConwayEra)
byId =
    ([TxId] -> [TxId] -> [TxId]) -> [(TxIn, [TxId])] -> Map TxIn [TxId]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
        (([TxId] -> [TxId] -> [TxId]) -> [TxId] -> [TxId] -> [TxId]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [TxId] -> [TxId] -> [TxId]
forall a. Semigroup a => a -> a -> a
(<>))
        [(TxIn
i, [TxId
tid]) | (TxId
tid, Tx TopTx ConwayEra
tx) <- Map TxId (Tx TopTx ConwayEra) -> [(TxId, Tx TopTx ConwayEra)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map TxId (Tx TopTx ConwayEra)
byId, TxIn
i <- Tx TopTx ConwayEra -> [TxIn]
spendingInputs Tx TopTx ConwayEra
tx]

{- | @create@: it mints exactly one of the token under @Minting(seed)@, spends
the seed, names the token @assetName(seed)@, and its first output is the
state address holding the token. Answers the root its state datum records.
-}
checkCreate
    :: RegistryIdentity -> TxId -> ConwayTx -> Either TrieFailure Root
checkCreate :: RegistryIdentity
-> TxId -> Tx TopTx ConwayEra -> Either TrieFailure Root
checkCreate token :: RegistryIdentity
token@(RegistryIdentity StatePolicyId
_ (AssetName ShortByteString
name)) TxId
tid Tx TopTx ConwayEra
tx = do
    let refuse :: Mismatch -> Either TrieFailure a
refuse = RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
forall a.
RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
failWith RegistryIdentity
token TxId
tid (Refuse -> Either TrieFailure a)
-> (Mismatch -> Refuse) -> Mismatch -> Either TrieFailure a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RegistryIdentity -> Maybe TxId -> Mismatch -> TrieFailure)
-> Mismatch -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Mismatch -> TrieFailure
WrongRegistry
        MultiAsset Map PolicyID (Map AssetName Integer)
minted = Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting MultiAsset (Tx TopTx ConwayEra) MultiAsset -> MultiAsset
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const MultiAsset (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const MultiAsset (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const MultiAsset (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const MultiAsset (Tx TopTx ConwayEra))
-> ((MultiAsset -> Const MultiAsset MultiAsset)
    -> TxBody TopTx ConwayEra
    -> Const MultiAsset (TxBody TopTx ConwayEra))
-> Getting MultiAsset (Tx TopTx ConwayEra) MultiAsset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiAsset -> Const MultiAsset MultiAsset)
-> TxBody TopTx ConwayEra
-> Const MultiAsset (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) MultiAsset
mintTxBodyL
    Bool -> Either TrieFailure () -> Either TrieFailure ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RegistryIdentity -> Map PolicyID (Map AssetName Integer) -> Integer
quantityIn RegistryIdentity
token Map PolicyID (Map AssetName Integer)
minted Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1) (Either TrieFailure () -> Either TrieFailure ())
-> Either TrieFailure () -> Either TrieFailure ()
forall a b. (a -> b) -> a -> b
$ Mismatch -> Either TrieFailure ()
forall {a}. Mismatch -> Either TrieFailure a
refuse Mismatch
CreateMint
    seed <- case (PolicyID -> Bool) -> [PolicyID] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
List.findIndex (RegistryIdentity -> PolicyID -> Bool
isPolicyOf RegistryIdentity
token) (Map PolicyID (Map AssetName Integer) -> [PolicyID]
forall k a. Map k a -> [k]
Map.keys Map PolicyID (Map AssetName Integer)
minted) of
        Just Int
ix
            | Just (Minting OnChainTxOutRef
seed) <-
                ConwayPlutusPurpose AsIx ConwayEra
-> Tx TopTx ConwayEra -> Maybe MintRedeemer
forall a.
FromData a =>
ConwayPlutusPurpose AsIx ConwayEra -> Tx TopTx ConwayEra -> Maybe a
redeemerAt (AsIx Word32 PolicyID -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 PolicyID -> ConwayPlutusPurpose f era
ConwayMinting (Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
AsIx (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix))) Tx TopTx ConwayEra
tx ->
                OnChainTxOutRef -> Either TrieFailure OnChainTxOutRef
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnChainTxOutRef
seed
        Maybe Int
_ -> Mismatch -> Either TrieFailure OnChainTxOutRef
forall {a}. Mismatch -> Either TrieFailure a
refuse Mismatch
CreateMint
    unless (any ((== seed) . txInToRef) (spendingInputs tx)) $
        refuse SeedNotSpent
    unless (deriveAssetName seed == SBS.fromShort name) $ refuse SeedName
    case outputAt tx (TxIx 0) of
        Just TxOut ConwayEra
o
            | RegistryIdentity -> TxOut ConwayEra -> Bool
holdsToken RegistryIdentity
token TxOut ConwayEra
o
            , Addr Network
_ (ScriptHashObj ScriptHash
h) StakeReference
_ <- TxOut ConwayEra
BabbageTxOut ConwayEra
o BabbageTxOut ConwayEra
-> Getting Addr (BabbageTxOut ConwayEra) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. (Addr -> Const Addr Addr)
-> TxOut ConwayEra -> Const Addr (TxOut ConwayEra)
Getting Addr (BabbageTxOut ConwayEra) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut ConwayEra) Addr
addrTxOutL
            , RegistryIdentity -> PolicyID -> Bool
isPolicyOf RegistryIdentity
token (ScriptHash -> PolicyID
PolicyID ScriptHash
h) ->
                () -> Either TrieFailure ()
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe (TxOut ConwayEra)
_ -> Mismatch -> Either TrieFailure ()
forall {a}. Mismatch -> Either TrieFailure a
refuse Mismatch
CreateOutput
    stateRootOf token tid tx

-- ---------------------------------------------------------
-- Replaying the folds
-- ---------------------------------------------------------

{- | Check @create@'s root against the empty trie, then apply each fold's
actions in chain order and check its root. The first mismatch refuses.
-}
replayFolds
    :: (Monad m)
    => Trie m
    -> RegistryIdentity
    -> Lineage
    -> m (Either TrieFailure Replayed)
replayFolds :: forall (m :: * -> *).
Monad m =>
Trie m
-> RegistryIdentity -> Lineage -> m (Either TrieFailure Replayed)
replayFolds Trie m
trie RegistryIdentity
token Lineage{[Fold]
TxId
Root
TxIn -> Either Incomplete (TxOut ConwayEra)
lineageCreate :: Lineage -> TxId
lineageCreateRoot :: Lineage -> Root
lineageFolds :: Lineage -> [Fold]
lineageResolve :: Lineage -> TxIn -> Either Incomplete (TxOut ConwayEra)
lineageCreate :: TxId
lineageCreateRoot :: Root
lineageFolds :: [Fold]
lineageResolve :: TxIn -> Either Incomplete (TxOut ConwayEra)
..} = do
    start <- Trie m -> m Root
forall (m :: * -> *). Trie m -> m Root
getRoot Trie m
trie
    if start /= emptyTrieRoot || lineageCreateRoot /= emptyTrieRoot
        then
            pure $
                failWith
                    token
                    lineageCreate
                    (chained start lineageCreateRoot)
        else go Set.empty lineageFolds
  where
    go :: Set ByteString -> [Fold] -> m (Either TrieFailure Replayed)
go Set ByteString
seen [] =
        Either TrieFailure Replayed -> m (Either TrieFailure Replayed)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( Replayed -> Either TrieFailure Replayed
forall a b. b -> Either a b
Right
                ( TxId -> [TxId] -> [ByteString] -> Replayed
Replayed
                    TxId
lineageCreate
                    ((Fold -> TxId) -> [Fold] -> [TxId]
forall a b. (a -> b) -> [a] -> [b]
map Fold -> TxId
foldId [Fold]
lineageFolds)
                    (Set ByteString -> [ByteString]
forall a. Set a -> [a]
Set.toAscList Set ByteString
seen)
                )
            )
    go Set ByteString
seen (fold :: Fold
fold@Fold{TxId
foldId :: Fold -> TxId
foldId :: TxId
foldId, Root
foldRoot :: Fold -> Root
foldRoot :: Root
foldRoot} : [Fold]
rest) =
        case RegistryIdentity
-> (TxIn -> Either Incomplete (TxOut ConwayEra))
-> Fold
-> Either TrieFailure [(OnChainRequest, RequestAction)]
pairing RegistryIdentity
token TxIn -> Either Incomplete (TxOut ConwayEra)
lineageResolve Fold
fold of
            Left TrieFailure
failure -> Either TrieFailure Replayed -> m (Either TrieFailure Replayed)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TrieFailure -> Either TrieFailure Replayed
forall a b. a -> Either a b
Left TrieFailure
failure)
            Right [(OnChainRequest, RequestAction)]
pairs -> do
                ((OnChainRequest, RequestAction) -> m ())
-> [(OnChainRequest, RequestAction)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((OnChainRequest -> RequestAction -> m ())
-> (OnChainRequest, RequestAction) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry OnChainRequest -> RequestAction -> m ()
apply) [(OnChainRequest, RequestAction)]
pairs
                rebuilt <- Trie m -> m Root
forall (m :: * -> *). Trie m -> m Root
getRoot Trie m
trie
                if rebuilt /= foldRoot
                    then pure (failWith token foldId (chained rebuilt foldRoot))
                    else go (Set.union seen (Set.fromList (appliedKeys pairs))) rest
    apply :: OnChainRequest -> RequestAction -> m ()
apply OnChainRequest{ByteString
requestKey :: OnChainRequest -> ByteString
requestKey :: ByteString
requestKey, Integer
requestEdge :: Integer
requestEdge :: OnChainRequest -> Integer
requestEdge} = \case
        Update [ProofStep]
_ -> m [ProofStep] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Trie m -> ByteString -> Integer -> m [ProofStep]
forall (m :: * -> *).
Monad m =>
Trie m -> ByteString -> Integer -> m [ProofStep]
walkEdge Trie m
trie ByteString
requestKey Integer
requestEdge)
        RequestAction
Rejected -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{- | The fold's actions paired with its requests, as the validator pairs them:
the state input's @Modify@ redeemer, and every spending input in ledger
order whose inline datum is a request naming this registry's token.
-}
pairing
    :: RegistryIdentity
    -> (TxIn -> Either Incomplete (TxOut ConwayEra))
    -> Fold
    -> Either TrieFailure [(OnChainRequest, RequestAction)]
pairing :: RegistryIdentity
-> (TxIn -> Either Incomplete (TxOut ConwayEra))
-> Fold
-> Either TrieFailure [(OnChainRequest, RequestAction)]
pairing RegistryIdentity
token TxIn -> Either Incomplete (TxOut ConwayEra)
resolve Fold{TxId
foldId :: Fold -> TxId
foldId :: TxId
foldId, Tx TopTx ConwayEra
foldTx :: Fold -> Tx TopTx ConwayEra
foldTx :: Tx TopTx ConwayEra
foldTx, TxIn
foldStateInput :: Fold -> TxIn
foldStateInput :: TxIn
foldStateInput} = do
    let refuse :: Refuse -> Either TrieFailure a
refuse = RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
forall a.
RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
failWith RegistryIdentity
token TxId
foldId
        inputs :: [TxIn]
inputs = Tx TopTx ConwayEra -> [TxIn]
spendingInputs Tx TopTx ConwayEra
foldTx
    actions <- case TxIn -> [TxIn] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex TxIn
foldStateInput [TxIn]
inputs of
        Maybe Int
Nothing -> Refuse -> Either TrieFailure [RequestAction]
forall {a}. Refuse -> Either TrieFailure a
refuse ((RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure)
-> Incomplete -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete Incomplete
NoStateInput)
        Just Int
ix -> case ConwayPlutusPurpose AsIx ConwayEra
-> Tx TopTx ConwayEra -> Maybe UpdateRedeemer
forall a.
FromData a =>
ConwayPlutusPurpose AsIx ConwayEra -> Tx TopTx ConwayEra -> Maybe a
redeemerAt (AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 TxIn -> ConwayPlutusPurpose f era
ConwaySpending (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix))) Tx TopTx ConwayEra
foldTx of
            Maybe UpdateRedeemer
Nothing -> Refuse -> Either TrieFailure [RequestAction]
forall {a}. Refuse -> Either TrieFailure a
refuse ((RegistryIdentity -> Maybe TxId -> Undecodable -> TrieFailure)
-> Undecodable -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Undecodable -> TrieFailure
UndecodableRequest Undecodable
MissingRedeemer)
            Just (Modify [RequestAction]
actions) -> [RequestAction] -> Either TrieFailure [RequestAction]
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [RequestAction]
actions
            Just UpdateRedeemer
_ -> Refuse -> Either TrieFailure [RequestAction]
forall {a}. Refuse -> Either TrieFailure a
refuse ((RegistryIdentity -> Maybe TxId -> Undecodable -> TrieFailure)
-> Undecodable -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Undecodable -> TrieFailure
UndecodableRequest Undecodable
NotModify)
    resolvedInputs <-
        traverse
            (either (refuse . because HistoryIncomplete) pure . resolve)
            inputs
    let requests =
            [ OnChainRequest
request
            | BabbageTxOut ConwayEra
o <- [BabbageTxOut ConwayEra]
resolvedInputs
            , Just (RequestDatum OnChainRequest
request) <- [TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
BabbageTxOut ConwayEra
o]
            , RegistryIdentity -> OnChainRequest -> Bool
requestNames RegistryIdentity
token OnChainRequest
request
            ]
    unless (length requests == length actions) $
        refuse
            ( because
                UndecodableRequest
                (ActionCount (length actions) (length requests))
            )
    pure (zip requests actions)

-- ---------------------------------------------------------
-- Reading transactions
-- ---------------------------------------------------------

{- | Whether the transaction's own bytes say its scripts passed. One with
@isValid = false@ spent only its collateral: the inputs its body names,
a state output among them, were not spent, so it is not in the lineage.
-}
passedScripts :: ConwayTx -> Bool
passedScripts :: Tx TopTx ConwayEra -> Bool
passedScripts Tx TopTx ConwayEra
tx = Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting IsValid (Tx TopTx ConwayEra) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx ConwayEra) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx ConwayEra) IsValid
isValidTxL IsValid -> IsValid -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
True

-- | A refusal about one transaction of the registry's history.
type Refuse = RegistryIdentity -> Maybe TxId -> TrieFailure

failWith :: RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
failWith :: forall a.
RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
failWith RegistryIdentity
token TxId
tid Refuse
refusal = TrieFailure -> Either TrieFailure a
forall a b. a -> Either a b
Left (Refuse
refusal RegistryIdentity
token (TxId -> Maybe TxId
forall a. a -> Maybe a
Just TxId
tid))

-- | A refusal of the given class, for the given reason.
because
    :: (RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because :: forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> r -> TrieFailure
refusal r
why RegistryIdentity
token Maybe TxId
tid = RegistryIdentity -> Maybe TxId -> r -> TrieFailure
refusal RegistryIdentity
token Maybe TxId
tid r
why

-- | A rebuilt root that is not the recorded one: rebuilt, recorded.
chained :: Root -> Root -> Refuse
chained :: Root -> Root -> Refuse
chained Root
rebuilt Root
recorded RegistryIdentity
token Maybe TxId
tid =
    RegistryIdentity -> Maybe TxId -> Parting -> TrieFailure
RootDoesNotChain RegistryIdentity
token Maybe TxId
tid (Root -> Root -> Parting
RootsPart Root
rebuilt Root
recorded)

-- | The spending inputs in ledger order.
spendingInputs :: ConwayTx -> [TxIn]
spendingInputs :: Tx TopTx ConwayEra -> [TxIn]
spendingInputs Tx TopTx ConwayEra
tx = Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toAscList (Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const (Set TxIn) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const (Set TxIn) (Tx TopTx ConwayEra))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx ConwayEra
    -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Getting (Set TxIn) (Tx TopTx ConwayEra) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx ConwayEra
-> Const (Set TxIn) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL)

outputs :: ConwayTx -> [TxOut ConwayEra]
outputs :: Tx TopTx ConwayEra -> [TxOut ConwayEra]
outputs Tx TopTx ConwayEra
tx = StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const
       (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
(StrictSeq (BabbageTxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra))
      (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL)

outputAt :: ConwayTx -> TxIx -> Maybe (TxOut ConwayEra)
outputAt :: Tx TopTx ConwayEra -> TxIx -> Maybe (TxOut ConwayEra)
outputAt Tx TopTx ConwayEra
tx (TxIx Word16
ix) = case Int -> [BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. Int -> [a] -> [a]
drop (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ix) (Tx TopTx ConwayEra -> [TxOut ConwayEra]
outputs Tx TopTx ConwayEra
tx) of
    BabbageTxOut ConwayEra
o : [BabbageTxOut ConwayEra]
_ -> BabbageTxOut ConwayEra -> Maybe (BabbageTxOut ConwayEra)
forall a. a -> Maybe a
Just BabbageTxOut ConwayEra
o
    [] -> Maybe (TxOut ConwayEra)
Maybe (BabbageTxOut ConwayEra)
forall a. Maybe a
Nothing

firstOutput :: TxId -> TxIn
firstOutput :: TxId -> TxIn
firstOutput TxId
tid = TxId -> TxIx -> TxIn
TxIn TxId
tid (Word16 -> TxIx
TxIx Word16
0)

-- | The root in the transaction's first output's inline state datum, which must hold the token.
stateRootOf
    :: RegistryIdentity -> TxId -> ConwayTx -> Either TrieFailure Root
stateRootOf :: RegistryIdentity
-> TxId -> Tx TopTx ConwayEra -> Either TrieFailure Root
stateRootOf RegistryIdentity
token TxId
tid Tx TopTx ConwayEra
tx = case Tx TopTx ConwayEra -> TxIx -> Maybe (TxOut ConwayEra)
outputAt Tx TopTx ConwayEra
tx (Word16 -> TxIx
TxIx Word16
0) of
    Just TxOut ConwayEra
o
        | RegistryIdentity -> TxOut ConwayEra -> Bool
holdsToken RegistryIdentity
token TxOut ConwayEra
o
        , Just (StateDatum OnChainTokenState
state) <- TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
o ->
            Root -> Either TrieFailure Root
forall a. a -> Either TrieFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Root
Root (OnChainRoot -> ByteString
unOnChainRoot (OnChainTokenState -> OnChainRoot
stateRoot OnChainTokenState
state)))
    Maybe (TxOut ConwayEra)
_ ->
        RegistryIdentity -> TxId -> Refuse -> Either TrieFailure Root
forall a.
RegistryIdentity -> TxId -> Refuse -> Either TrieFailure a
failWith RegistryIdentity
token TxId
tid ((RegistryIdentity -> Maybe TxId -> Undecodable -> TrieFailure)
-> Undecodable -> Refuse
forall r.
(RegistryIdentity -> Maybe TxId -> r -> TrieFailure) -> r -> Refuse
because RegistryIdentity -> Maybe TxId -> Undecodable -> TrieFailure
UndecodableRequest Undecodable
UndecodableStateOutput)

holdsToken :: RegistryIdentity -> TxOut ConwayEra -> Bool
holdsToken :: RegistryIdentity -> TxOut ConwayEra -> Bool
holdsToken RegistryIdentity
token TxOut ConwayEra
o =
    let MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
assets) = TxOut ConwayEra
BabbageTxOut ConwayEra
o BabbageTxOut ConwayEra
-> Getting MaryValue (BabbageTxOut ConwayEra) MaryValue
-> MaryValue
forall s a. s -> Getting a s a -> a
^. Getting MaryValue (BabbageTxOut ConwayEra) MaryValue
(Value ConwayEra -> Const MaryValue (Value ConwayEra))
-> TxOut ConwayEra -> Const MaryValue (TxOut ConwayEra)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut ConwayEra) (Value ConwayEra)
valueTxOutL
    in  RegistryIdentity -> Map PolicyID (Map AssetName Integer) -> Integer
quantityIn RegistryIdentity
token Map PolicyID (Map AssetName Integer)
assets Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1

mintsToken :: RegistryIdentity -> ConwayTx -> Bool
mintsToken :: RegistryIdentity -> Tx TopTx ConwayEra -> Bool
mintsToken RegistryIdentity
token Tx TopTx ConwayEra
tx =
    let MultiAsset Map PolicyID (Map AssetName Integer)
minted = Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting MultiAsset (Tx TopTx ConwayEra) MultiAsset -> MultiAsset
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const MultiAsset (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Const MultiAsset (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const MultiAsset (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Const MultiAsset (Tx TopTx ConwayEra))
-> ((MultiAsset -> Const MultiAsset MultiAsset)
    -> TxBody TopTx ConwayEra
    -> Const MultiAsset (TxBody TopTx ConwayEra))
-> Getting MultiAsset (Tx TopTx ConwayEra) MultiAsset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiAsset -> Const MultiAsset MultiAsset)
-> TxBody TopTx ConwayEra
-> Const MultiAsset (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) MultiAsset
mintTxBodyL
    in  RegistryIdentity -> Map PolicyID (Map AssetName Integer) -> Integer
quantityIn RegistryIdentity
token Map PolicyID (Map AssetName Integer)
minted Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0

quantityIn
    :: RegistryIdentity -> Map PolicyID (Map AssetName Integer) -> Integer
quantityIn :: RegistryIdentity -> Map PolicyID (Map AssetName Integer) -> Integer
quantityIn token :: RegistryIdentity
token@(RegistryIdentity StatePolicyId
_ AssetName
name) Map PolicyID (Map AssetName Integer)
assets =
    [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
        [ Integer -> AssetName -> Map AssetName Integer -> Integer
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Integer
0 AssetName
name Map AssetName Integer
names
        | (PolicyID
policy, Map AssetName Integer
names) <- Map PolicyID (Map AssetName Integer)
-> [(PolicyID, Map AssetName Integer)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PolicyID (Map AssetName Integer)
assets
        , RegistryIdentity -> PolicyID -> Bool
isPolicyOf RegistryIdentity
token PolicyID
policy
        ]

-- | Whether a policy is the registry's state policy.
isPolicyOf :: RegistryIdentity -> PolicyID -> Bool
isPolicyOf :: RegistryIdentity -> PolicyID -> Bool
isPolicyOf (RegistryIdentity (StatePolicyId ByteString
policy) AssetName
_) (PolicyID ScriptHash
h) =
    ScriptHash -> ByteString
scriptHashBytes ScriptHash
h ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
policy

-- | Whether a request names this registry's token, as the validator compares it.
requestNames :: RegistryIdentity -> OnChainRequest -> Bool
requestNames :: RegistryIdentity -> OnChainRequest -> Bool
requestNames (RegistryIdentity StatePolicyId
_ (AssetName ShortByteString
name)) OnChainRequest
request =
    let OnChainTokenId (BuiltinByteString ByteString
named) = OnChainRequest -> OnChainTokenId
requestToken OnChainRequest
request
    in  ByteString
named ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ShortByteString -> ByteString
SBS.fromShort ShortByteString
name

-- | A redeemer of the transaction, decoded.
redeemerAt
    :: (FromData a)
    => ConwayPlutusPurpose AsIx ConwayEra -> ConwayTx -> Maybe a
redeemerAt :: forall a.
FromData a =>
ConwayPlutusPurpose AsIx ConwayEra -> Tx TopTx ConwayEra -> Maybe a
redeemerAt ConwayPlutusPurpose AsIx ConwayEra
purpose Tx TopTx ConwayEra
tx = do
    let Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
redeemers = Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting
     (Redeemers ConwayEra) (Tx TopTx ConwayEra) (Redeemers ConwayEra)
-> Redeemers ConwayEra
forall s a. s -> Getting a s a -> a
^. (AlonzoTxWits ConwayEra
 -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra)
(TxWits ConwayEra
 -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra
  -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra
     -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra
    -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> Getting
     (Redeemers ConwayEra) (Tx TopTx ConwayEra) (Redeemers ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra
-> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra)
(Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> TxWits ConwayEra
-> Const (Redeemers ConwayEra) (TxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL
    (datum, _) <- ConwayPlutusPurpose AsIx ConwayEra
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Maybe (Data ConwayEra, ExUnits)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConwayPlutusPurpose AsIx ConwayEra
purpose Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
redeemers
    fromBuiltinData (BuiltinData (getPlutusData datum))

-- | The root of the empty trie, which @create@ records.
emptyTrieRoot :: Root
emptyTrieRoot :: Root
emptyTrieRoot = ByteString -> Root
Root ByteString
emptyRoot