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

-- | Fresh, session-bound public replay. No nodes or selections survive a read.
module Singular.Registry.TrieState.Lineage
    ( lineageTrieState
    , lineageTrieStateObserved
    ) where

import Cardano.Crypto.Hash (hashFromBytes)
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Api.Tx (bodyTxL, isValidTxL, txIdTx)
import Cardano.Ledger.Api.Tx.Body (outputsTxBodyL)
import Cardano.Ledger.Api.Tx.Out (TxOut, valueTxOutL)
import Cardano.Ledger.BaseTypes (TxIx (..))
import Cardano.Ledger.Binary (decCBOR, decodeFullAnnotator)
import Cardano.Ledger.Core (eraProtVerHigh)
import Cardano.Ledger.Hashes (ScriptHash (..))
import Cardano.Ledger.Mary.Value
    ( MaryValue (..)
    , MultiAsset (..)
    , PolicyID (..)
    )
import Cardano.Ledger.TxIn (TxId, TxIn (..))
import Cardano.Tx.Ledger (ConwayTx)
import Control.Monad (foldM, forM_, unless)
import Control.Monad.State.Strict (runState)
import Data.ByteString.Lazy qualified as BSL
import Data.Foldable (toList)
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Lens.Micro ((^.))
import MPF.Backend.Pure (emptyMPFInMemoryDB)
import Singular.Registry.Ledger (ConwayEra)
import Singular.Registry.LedgerProvider qualified as LP
import Singular.Registry.Replay
    ( Replayed (..)
    , replayLineage
    , replayedLineage
    )
import Singular.Registry.Trie.Pure (stateTrie)
import Singular.Registry.TrieState.Core (snapshotObserved)
import Singular.Registry.TrieState.Types

lineageTrieState :: (Monad m) => LP.Session w m -> TrieState m
lineageTrieState :: forall (m :: * -> *) w. Monad m => Session w m -> TrieState m
lineageTrieState Session w m
session = Session w m -> (TrieObservation -> m ()) -> TrieState m
forall (m :: * -> *) w.
Monad m =>
Session w m -> (TrieObservation -> m ()) -> TrieState m
lineageTrieStateObserved Session w m
session (m () -> TrieObservation -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

lineageTrieStateObserved
    :: (Monad m)
    => LP.Session w m
    -> (TrieObservation -> m ())
    -> TrieState m
lineageTrieStateObserved :: forall (m :: * -> *) w.
Monad m =>
Session w m -> (TrieObservation -> m ()) -> TrieState m
lineageTrieStateObserved Session w m
session TrieObservation -> m ()
emit = (forall a.
 TrieSelection
 -> (TrieSnapshot m -> m a) -> m (Either TrieFailure a))
-> (ObservedFold -> m (Either TrieFailure ())) -> TrieState m
forall (m :: * -> *).
(forall a.
 TrieSelection
 -> (TrieSnapshot m -> m a) -> m (Either TrieFailure a))
-> (ObservedFold -> m (Either TrieFailure ())) -> TrieState m
TrieState TrieSelection
-> (TrieSnapshot m -> m a) -> m (Either TrieFailure a)
forall a.
TrieSelection
-> (TrieSnapshot m -> m a) -> m (Either TrieFailure a)
select ObservedFold -> m (Either TrieFailure ())
forall {a}. ObservedFold -> m (Either a ())
accept
  where
    select :: TrieSelection
-> (TrieSnapshot m -> m b) -> m (Either TrieFailure b)
select TrieSelection
chosen TrieSnapshot m -> m b
use
        | StatePoint -> SessionId
pointSession StatePoint
point SessionId -> SessionId -> Bool
forall a. Eq a => a -> a -> Bool
/= Session w m -> SessionId
forall w (m :: * -> *). Session w m -> SessionId
LP.sessionId Session w m
session
            Bool -> Bool -> Bool
|| StatePoint -> SessionBinding
pointBinding StatePoint
point SessionBinding -> SessionBinding -> Bool
forall a. Eq a => a -> a -> Bool
/= Session w m -> SessionBinding
forall w (m :: * -> *). Session w m -> SessionBinding
LP.sessionBinding Session w m
session =
            Either TrieFailure b -> m (Either TrieFailure b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TrieFailure -> Either TrieFailure b
forall a b. a -> Either a b
Left (RegistryIdentity -> Maybe TxId -> Staleness -> TrieFailure
StaleState RegistryIdentity
who Maybe TxId
forall a. Maybe a
Nothing Staleness
NoSelection))
        | Bool
otherwise = case RegistryIdentity -> Maybe Asset
assetOf RegistryIdentity
who of
            Maybe Asset
Nothing -> Either TrieFailure b -> m (Either TrieFailure b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TrieFailure -> Either TrieFailure b
forall a b. a -> Either a b
Left (RegistryIdentity -> Maybe TxId -> Mismatch -> TrieFailure
WrongRegistry RegistryIdentity
who Maybe TxId
forall a. Maybe a
Nothing Mismatch
UnknownRegistry))
            Just Asset
asset -> do
                supplied <- Session w m
-> Asset
-> HistoryRange
-> m (Either HistoryFailure (HistoryStream m))
forall w (m :: * -> *).
Session w m
-> Asset
-> HistoryRange
-> m (Either HistoryFailure (HistoryStream m))
LP.history Session w m
session Asset
asset (Maybe Word64 -> Maybe Word64 -> HistoryRange
LP.HistoryRange Maybe Word64
forall a. Maybe a
Nothing Maybe Word64
forall a. Maybe a
Nothing)
                material <- case supplied of
                    Left HistoryFailure
failure -> Either TrieFailure [HistoryBlock]
-> m (Either TrieFailure [HistoryBlock])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TrieFailure -> Either TrieFailure [HistoryBlock]
forall a b. a -> Either a b
Left (RegistryIdentity -> HistoryFailure -> TrieFailure
providerRefusal RegistryIdentity
who HistoryFailure
failure))
                    Right HistoryStream m
stream -> RegistryIdentity
-> HistoryStream m -> m (Either TrieFailure [HistoryBlock])
forall (m :: * -> *).
Monad m =>
RegistryIdentity
-> HistoryStream m -> m (Either TrieFailure [HistoryBlock])
drain RegistryIdentity
who HistoryStream m
stream
                case material >>= checkBlocks who asset of
                    Left TrieFailure
why -> Either TrieFailure b -> m (Either TrieFailure b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TrieFailure -> Either TrieFailure b
forall a b. a -> Either a b
Left TrieFailure
why)
                    Right (Map TxIn (BabbageTxOut ConwayEra)
resolved, [ConwayTx]
transactions) -> do
                        let (Either TrieFailure Replayed
answer, MPFInMemoryDB
nodes) =
                                State MPFInMemoryDB (Either TrieFailure Replayed)
-> MPFInMemoryDB -> (Either TrieFailure Replayed, MPFInMemoryDB)
forall s a. State s a -> s -> (a, s)
runState
                                    ( Trie (StateT MPFInMemoryDB Identity)
-> RegistryIdentity
-> TxIn
-> Root
-> Map TxIn (TxOut ConwayEra)
-> [ConwayTx]
-> State MPFInMemoryDB (Either TrieFailure Replayed)
forall (m :: * -> *).
Monad m =>
Trie m
-> RegistryIdentity
-> TxIn
-> Root
-> Map TxIn (TxOut ConwayEra)
-> [ConwayTx]
-> m (Either TrieFailure Replayed)
replayLineage
                                        Trie (StateT MPFInMemoryDB Identity)
stateTrie
                                        RegistryIdentity
who
                                        (StatePoint -> TxIn
pointOutput StatePoint
point)
                                        (TrieSelection -> Root
trieSelectionRoot TrieSelection
chosen)
                                        Map TxIn (TxOut ConwayEra)
Map TxIn (BabbageTxOut ConwayEra)
resolved
                                        [ConwayTx]
transactions
                                    )
                                    MPFInMemoryDB
emptyMPFInMemoryDB
                        case Either TrieFailure Replayed
answer of
                            Left TrieFailure
why -> Either TrieFailure b -> m (Either TrieFailure b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TrieFailure -> Either TrieFailure b
forall a b. a -> Either a b
Left TrieFailure
why)
                            Right replayed :: Replayed
replayed@Replayed{[TxId]
replayedFolds :: [TxId]
replayedFolds :: Replayed -> [TxId]
replayedFolds} -> do
                                TrieObservation -> m ()
emit (TrieSelection -> TrieObservation
Selected TrieSelection
chosen)
                                b -> Either TrieFailure b
forall a b. b -> Either a b
Right
                                    (b -> Either TrieFailure b) -> m b -> m (Either TrieFailure b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrieSnapshot m -> m b
use
                                        ( (TrieObservation -> m ())
-> TrieSelection
-> MPFInMemoryDB
-> CompleteFromCreate
-> Maybe PublicLineage
-> TrieSnapshot m
forall (m :: * -> *).
Monad m =>
(TrieObservation -> m ())
-> TrieSelection
-> MPFInMemoryDB
-> CompleteFromCreate
-> Maybe PublicLineage
-> TrieSnapshot m
snapshotObserved
                                            TrieObservation -> m ()
emit
                                            TrieSelection
chosen
                                            MPFInMemoryDB
nodes
                                            (Int -> CompleteFromCreate
CompleteFromCreate ([TxId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxId]
replayedFolds))
                                            (PublicLineage -> Maybe PublicLineage
forall a. a -> Maybe a
Just (Replayed -> PublicLineage
replayedLineage Replayed
replayed))
                                        )
      where
        who :: RegistryIdentity
who = TrieSelection -> RegistryIdentity
trieSelectionIdentity TrieSelection
chosen
        point :: StatePoint
point = TrieSelection -> StatePoint
trieSelectionPoint TrieSelection
chosen
    -- Inclusion is established by the caller. It creates no cache, so the
    -- next selection must obtain and replay public history again.
    accept :: ObservedFold -> m (Either a ())
accept (ObservedFold TrieSelection
from TrieSelection
to NonEmpty (ByteString, Integer)
_) = do
        TrieObservation -> m ()
emit (TrieSelection -> TrieSelection -> TrieObservation
FoldAccepted TrieSelection
from TrieSelection
to)
        Either a () -> m (Either a ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either a ()
forall a b. b -> Either a b
Right ())

assetOf :: RegistryIdentity -> Maybe LP.Asset
assetOf :: RegistryIdentity -> Maybe Asset
assetOf (RegistryIdentity (StatePolicyId ByteString
policy) AssetName
name) =
    (,AssetName
name) (PolicyID -> Asset)
-> (Hash ADDRHASH EraIndependentScript -> PolicyID)
-> Hash ADDRHASH EraIndependentScript
-> Asset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> PolicyID
PolicyID (ScriptHash -> PolicyID)
-> (Hash ADDRHASH EraIndependentScript -> ScriptHash)
-> Hash ADDRHASH EraIndependentScript
-> PolicyID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash ADDRHASH EraIndependentScript -> ScriptHash
ScriptHash (Hash ADDRHASH EraIndependentScript -> Asset)
-> Maybe (Hash ADDRHASH EraIndependentScript) -> Maybe Asset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Hash ADDRHASH EraIndependentScript)
forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
hashFromBytes ByteString
policy

drain
    :: (Monad m)
    => RegistryIdentity
    -> LP.HistoryStream m
    -> m (Either TrieFailure [LP.HistoryBlock])
drain :: forall (m :: * -> *).
Monad m =>
RegistryIdentity
-> HistoryStream m -> m (Either TrieFailure [HistoryBlock])
drain RegistryIdentity
who = Maybe Word64
-> [HistoryBlock]
-> HistoryStream m
-> m (Either TrieFailure [HistoryBlock])
forall {m :: * -> *}.
Monad m =>
Maybe Word64
-> [HistoryBlock]
-> HistoryStream m
-> m (Either TrieFailure [HistoryBlock])
go Maybe Word64
forall a. Maybe a
Nothing []
  where
    go :: Maybe Word64
-> [HistoryBlock]
-> HistoryStream m
-> m (Either TrieFailure [HistoryBlock])
go Maybe Word64
previous [HistoryBlock]
reversed HistoryStream m
stream =
        HistoryStream m
-> m (Either
        HistoryFailure (Maybe (HistoryBlock, HistoryStream m)))
forall (m :: * -> *).
HistoryStream m
-> m (Either
        HistoryFailure (Maybe (HistoryBlock, HistoryStream m)))
LP.nextBlock HistoryStream m
stream m (Either HistoryFailure (Maybe (HistoryBlock, HistoryStream m)))
-> (Either HistoryFailure (Maybe (HistoryBlock, HistoryStream m))
    -> m (Either TrieFailure [HistoryBlock]))
-> m (Either TrieFailure [HistoryBlock])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left HistoryFailure
failure -> Either TrieFailure [HistoryBlock]
-> m (Either TrieFailure [HistoryBlock])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TrieFailure -> Either TrieFailure [HistoryBlock]
forall a b. a -> Either a b
Left (RegistryIdentity -> HistoryFailure -> TrieFailure
providerRefusal RegistryIdentity
who HistoryFailure
failure))
            Right Maybe (HistoryBlock, HistoryStream m)
Nothing -> Either TrieFailure [HistoryBlock]
-> m (Either TrieFailure [HistoryBlock])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HistoryBlock] -> Either TrieFailure [HistoryBlock]
forall a b. b -> Either a b
Right ([HistoryBlock] -> [HistoryBlock]
forall a. [a] -> [a]
reverse [HistoryBlock]
reversed))
            Right (Just (HistoryBlock
block, HistoryStream m
rest)) -> case Maybe Word64
previous of
                Just Word64
height
                    | HistoryBlock -> Word64
LP.blockHeight HistoryBlock
block Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
height ->
                        Either TrieFailure [HistoryBlock]
-> m (Either TrieFailure [HistoryBlock])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                            ( TrieFailure -> Either TrieFailure [HistoryBlock]
forall a b. a -> Either a b
Left
                                ( RegistryIdentity -> HistoryFailure -> TrieFailure
providerRefusal
                                    RegistryIdentity
who
                                    (Word64 -> Word64 -> HistoryFailure
LP.HistoryOrderMismatch Word64
height (HistoryBlock -> Word64
LP.blockHeight HistoryBlock
block))
                                )
                            )
                Maybe Word64
_ -> Maybe Word64
-> [HistoryBlock]
-> HistoryStream m
-> m (Either TrieFailure [HistoryBlock])
go (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (HistoryBlock -> Word64
LP.blockHeight HistoryBlock
block)) (HistoryBlock
block HistoryBlock -> [HistoryBlock] -> [HistoryBlock]
forall a. a -> [a] -> [a]
: [HistoryBlock]
reversed) HistoryStream m
rest

checkBlocks
    :: RegistryIdentity
    -> LP.Asset
    -> [LP.HistoryBlock]
    -> Either TrieFailure (Map TxIn (TxOut ConwayEra), [ConwayTx])
checkBlocks :: RegistryIdentity
-> Asset
-> [HistoryBlock]
-> Either TrieFailure (Map TxIn (TxOut ConwayEra), [ConwayTx])
checkBlocks RegistryIdentity
who Asset
asset [HistoryBlock]
blocks = do
    (resolved, reversed) <- ((Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
 -> HistoryBlock
 -> Either
      TrieFailure (Map TxIn (BabbageTxOut ConwayEra), [ConwayTx]))
-> (Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
-> [HistoryBlock]
-> Either
     TrieFailure (Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
-> HistoryBlock
-> Either
     TrieFailure (Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
block (Map TxIn (BabbageTxOut ConwayEra)
forall k a. Map k a
Map.empty, []) [HistoryBlock]
blocks
    pure (resolved, reverse reversed)
  where
    block :: (Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
-> HistoryBlock
-> Either
     TrieFailure (Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
block (Map TxIn (BabbageTxOut ConwayEra)
resolved, [ConwayTx]
transactions) HistoryBlock
whole = do
        let records :: [HistoricalTransaction]
records = NonEmpty HistoricalTransaction -> [HistoricalTransaction]
forall a. NonEmpty a -> [a]
NE.toList (HistoryBlock -> NonEmpty HistoricalTransaction
LP.blockTransactions HistoryBlock
whole)
            creators :: Set TxId
creators = [TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList ((HistoricalTransaction -> TxId)
-> [HistoricalTransaction] -> [TxId]
forall a b. (a -> b) -> [a] -> [b]
map HistoricalTransaction -> TxId
LP.historicalId [HistoricalTransaction]
records)
        (_, after, reversed) <-
            ((Set TxId, Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
 -> HistoricalTransaction
 -> Either
      TrieFailure
      (Set TxId, Map TxIn (BabbageTxOut ConwayEra), [ConwayTx]))
-> (Set TxId, Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
-> [HistoricalTransaction]
-> Either
     TrieFailure
     (Set TxId, Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
                (Set TxId
-> (Set TxId, Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
-> HistoricalTransaction
-> Either
     TrieFailure
     (Set TxId, Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
transaction Set TxId
creators)
                (Set TxId
forall a. Set a
Set.empty, Map TxIn (BabbageTxOut ConwayEra)
resolved, [ConwayTx]
transactions)
                [HistoricalTransaction]
records
        pure (after, reversed)
    transaction :: Set TxId
-> (Set TxId, Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
-> HistoricalTransaction
-> Either
     TrieFailure
     (Set TxId, Map TxIn (BabbageTxOut ConwayEra), [ConwayTx])
transaction Set TxId
creators (Set TxId
seen, Map TxIn (BabbageTxOut ConwayEra)
resolved, [ConwayTx]
transactions) HistoricalTransaction
record = do
        tx <- HistoricalTransaction -> Either TrieFailure ConwayTx
decode HistoricalTransaction
record
        forM_ (LP.spentOutputs record) $ \(TxIn TxId
creator TxIx
_, BabbageTxOut ConwayEra
output) ->
            Bool -> Either TrieFailure () -> Either TrieFailure ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
                ( Bool -> Bool
not (Asset -> TxOut ConwayEra -> Bool
holds Asset
asset TxOut ConwayEra
BabbageTxOut ConwayEra
output)
                    Bool -> Bool -> Bool
|| Bool -> Bool
not (TxId -> Set TxId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TxId
creator Set TxId
creators)
                    Bool -> Bool -> Bool
|| TxId -> Set TxId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TxId
creator Set TxId
seen
                )
                (Either TrieFailure () -> Either TrieFailure ())
-> Either TrieFailure () -> Either TrieFailure ()
forall a b. (a -> b) -> a -> b
$ TrieFailure -> Either TrieFailure ()
forall a b. a -> Either a b
Left
                    ( RegistryIdentity -> HistoryFailure -> TrieFailure
providerRefusal
                        RegistryIdentity
who
                        (TxId -> TxId -> HistoryFailure
LP.MissingInBlockParent (HistoricalTransaction -> TxId
LP.historicalId HistoricalTransaction
record) TxId
creator)
                    )
        let produced =
                (Word16
 -> BabbageTxOut ConwayEra -> (TxIn, BabbageTxOut ConwayEra))
-> [Word16]
-> [BabbageTxOut ConwayEra]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                    (\Word16
index BabbageTxOut ConwayEra
output -> (TxId -> TxIx -> TxIn
TxIn (ConwayTx -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx ConwayTx
tx) (Word16 -> TxIx
TxIx Word16
index), BabbageTxOut ConwayEra
output))
                    [Word16
0 ..]
                    (StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (ConwayTx
tx ConwayTx
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     ConwayTx
     (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))
-> ConwayTx -> Const (StrictSeq (BabbageTxOut ConwayEra)) ConwayTx
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))
 -> ConwayTx -> Const (StrictSeq (BabbageTxOut ConwayEra)) ConwayTx)
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     ConwayTx
     (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))
        unless (produced == LP.createdOutputs record) $
            mismatch record "created outputs disagree with transaction CBOR"
        after <-
            foldM
                merge
                resolved
                (LP.spentOutputs record <> LP.referenceOutputs record <> produced)
        pure (Set.insert (txIdTx tx) seen, after, tx : transactions)
    decode :: HistoricalTransaction -> Either TrieFailure ConwayTx
decode HistoricalTransaction
record = do
        tx <-
            (DecoderError -> Either TrieFailure ConwayTx)
-> (ConwayTx -> Either TrieFailure ConwayTx)
-> Either DecoderError ConwayTx
-> Either TrieFailure ConwayTx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                ( \DecoderError
why ->
                    HistoricalTransaction -> Text -> Either TrieFailure ConwayTx
forall {b}. HistoricalTransaction -> Text -> Either TrieFailure b
mismatch
                        HistoricalTransaction
record
                        (Text
"transaction CBOR cannot be decoded: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (DecoderError -> String
forall a. Show a => a -> String
show DecoderError
why))
                )
                ConwayTx -> Either TrieFailure ConwayTx
forall a b. b -> Either a b
Right
                ( Version
-> Text
-> (forall s. Decoder s (Annotator ConwayTx))
-> ByteString
-> Either DecoderError ConwayTx
forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator
                    (forall era. Era era => Version
eraProtVerHigh @ConwayEra)
                    Text
"ConwayTx"
                    Decoder s (Annotator ConwayTx)
forall s. Decoder s (Annotator ConwayTx)
forall a s. DecCBOR a => Decoder s a
decCBOR
                    (ByteString -> ByteString
BSL.fromStrict (HistoricalTransaction -> ByteString
LP.historicalCbor HistoricalTransaction
record))
                )
        unless
            (tx == LP.historicalTx record && txIdTx tx == LP.historicalId record)
            $ mismatch record "transaction body or identity disagrees with CBOR"
        unless ((tx ^. isValidTxL == IsValid True) == LP.scriptValid record) $
            mismatch record "script validity disagrees with CBOR"
        pure tx
    mismatch :: HistoricalTransaction -> Text -> Either TrieFailure b
mismatch HistoricalTransaction
record Text
message =
        TrieFailure -> Either TrieFailure b
forall a b. a -> Either a b
Left
            ( RegistryIdentity -> HistoryFailure -> TrieFailure
providerRefusal
                RegistryIdentity
who
                (TxId -> Text -> HistoryFailure
LP.HistoryMaterialMismatch (HistoricalTransaction -> TxId
LP.historicalId HistoricalTransaction
record) Text
message)
            )
    merge :: Map TxIn a -> (TxIn, a) -> Either TrieFailure (Map TxIn a)
merge Map TxIn a
resolved (TxIn
input, a
output) = case TxIn -> Map TxIn a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
input Map TxIn a
resolved of
        Just a
old
            | a
old a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
output ->
                TrieFailure -> Either TrieFailure (Map TxIn a)
forall a b. a -> Either a b
Left
                    ( RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete
                        RegistryIdentity
who
                        (TxId -> Maybe TxId
forall a. a -> Maybe a
Just (TxIn -> TxId
inputId TxIn
input))
                        (TxIn -> Incomplete
ConflictingResolution TxIn
input)
                    )
        Maybe a
_ -> Map TxIn a -> Either TrieFailure (Map TxIn a)
forall a b. b -> Either a b
Right (TxIn -> a -> Map TxIn a -> Map TxIn a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
input a
output Map TxIn a
resolved)

holds :: LP.Asset -> TxOut ConwayEra -> Bool
holds :: Asset -> TxOut ConwayEra -> Bool
holds (PolicyID
policy, AssetName
name) TxOut ConwayEra
output =
    let MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
assets) = TxOut ConwayEra
BabbageTxOut ConwayEra
output 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  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
-> PolicyID
-> Map PolicyID (Map AssetName Integer)
-> Map AssetName Integer
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map AssetName Integer
forall k a. Map k a
Map.empty PolicyID
policy Map PolicyID (Map AssetName Integer)
assets)
            Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0

inputId :: TxIn -> TxId
inputId :: TxIn -> TxId
inputId (TxIn TxId
tx TxIx
_) = TxId
tx

providerRefusal
    :: RegistryIdentity -> LP.HistoryFailure -> TrieFailure
providerRefusal :: RegistryIdentity -> HistoryFailure -> TrieFailure
providerRefusal RegistryIdentity
who HistoryFailure
failure = RegistryIdentity -> Maybe TxId -> Incomplete -> TrieFailure
HistoryIncomplete RegistryIdentity
who Maybe TxId
transaction (HistoryFailure -> Incomplete
ProviderHistoryFailure HistoryFailure
failure)
  where
    transaction :: Maybe TxId
transaction = case HistoryFailure
failure of
        LP.HistoryReadFailure (LP.MissingOutput TxIn
input) -> TxId -> Maybe TxId
forall a. a -> Maybe a
Just (TxIn -> TxId
inputId TxIn
input)
        LP.HistoryReadFailure (LP.ConflictingOutput TxIn
input) -> TxId -> Maybe TxId
forall a. a -> Maybe a
Just (TxIn -> TxId
inputId TxIn
input)
        LP.HistoryDependencyCycle (TxId
tx NE.:| [TxId]
_) -> TxId -> Maybe TxId
forall a. a -> Maybe a
Just TxId
tx
        LP.MissingInBlockParent TxId
tx TxId
_ -> TxId -> Maybe TxId
forall a. a -> Maybe a
Just TxId
tx
        LP.DuplicateSpend TxIn
input -> TxId -> Maybe TxId
forall a. a -> Maybe a
Just (TxIn -> TxId
inputId TxIn
input)
        LP.HistoryMaterialMismatch TxId
tx Text
_ -> TxId -> Maybe TxId
forall a. a -> Maybe a
Just TxId
tx
        HistoryFailure
_ -> Maybe TxId
forall a. Maybe a
Nothing