{-# LANGUAGE LambdaCase #-}

{- | Complete blocks over the shared client's deferred pages. Asset spend
dependencies determine replay order; unrelated funding stays outside it.
-}
module Singular.Provider.Koios.History (assetHistory) where

import Cardano.Ledger.Api.Tx (bodyTxL)
import Cardano.Ledger.Api.Tx.Body
    ( inputsTxBodyL
    , outputsTxBodyL
    , referenceInputsTxBodyL
    )
import Cardano.Ledger.Api.Tx.Out (TxOut, valueTxOutL)
import Cardano.Ledger.BaseTypes (TxIx (..))
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..))
import Cardano.Ledger.TxIn (TxId, TxIn (..))
import Control.Monad (unless)
import Control.Monad qualified
import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
import Data.Bifunctor (first)
import Data.Foldable (toList)
import Data.List (sortOn)
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Word (Word64)
import Lens.Micro ((^.))
import Singular.Provider.Koios.Client qualified as Client
import Singular.Provider.Koios.Wire qualified as Wire
import Singular.Registry.LedgerProvider

{- | Start only the listing's first page. Material for a complete block is
read when its continuation is consumed, with at most one lookahead page.
-}
assetHistory
    :: (Monad m)
    => Client.Koios m
    -> Asset
    -> HistoryRange
    -> m (Either HistoryFailure (HistoryStream m))
assetHistory :: forall (m :: * -> *).
Monad m =>
Koios m
-> Asset
-> HistoryRange
-> m (Either HistoryFailure (HistoryStream m))
assetHistory Koios m
client Asset
asset HistoryRange
range = do
    firstPage <- (PolicyID
 -> AssetName -> m (Either ClientFailure (Page m AssetTx)))
-> Asset -> m (Either ClientFailure (Page m AssetTx))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Koios m
-> PolicyID
-> AssetName
-> m (Either ClientFailure (Page m AssetTx))
forall (m :: * -> *).
Monad m =>
Koios m
-> PolicyID
-> AssetName
-> m (Either ClientFailure (Page m AssetTx))
Client.assetTxsPage Koios m
client) Asset
asset
    pure $
        first readFailure firstPage >>= \Page m AssetTx
page ->
            HistoryStream m -> Either HistoryFailure (HistoryStream m)
forall a b. b -> Either a b
Right
                (Set TxIn
-> [Word64]
-> [AssetTx]
-> Maybe (m (Either ClientFailure (Page m AssetTx)))
-> HistoryStream m
stream Set TxIn
forall a. Set a
Set.empty [] (Page m AssetTx -> [AssetTx]
forall (m :: * -> *) a. Page m a -> [a]
Client.pageRows Page m AssetTx
page) (Page m AssetTx -> Maybe (m (Either ClientFailure (Page m AssetTx)))
forall (m :: * -> *) a.
Page m a -> Maybe (m (Either ClientFailure (Page m a)))
Client.nextPage Page m AssetTx
page))
  where
    stream :: Set TxIn
-> [Word64]
-> [AssetTx]
-> Maybe (m (Either ClientFailure (Page m AssetTx)))
-> HistoryStream m
stream Set TxIn
spent [Word64]
previous [AssetTx]
rows Maybe (m (Either ClientFailure (Page m AssetTx)))
more = m (Either HistoryFailure (Maybe (HistoryBlock, HistoryStream m)))
-> HistoryStream m
forall (m :: * -> *).
m (Either HistoryFailure (Maybe (HistoryBlock, HistoryStream m)))
-> HistoryStream m
HistoryStream (m (Either HistoryFailure (Maybe (HistoryBlock, HistoryStream m)))
 -> HistoryStream m)
-> m (Either
        HistoryFailure (Maybe (HistoryBlock, HistoryStream m)))
-> HistoryStream m
forall a b. (a -> b) -> a -> b
$ ExceptT HistoryFailure m (Maybe (HistoryBlock, HistoryStream m))
-> m (Either
        HistoryFailure (Maybe (HistoryBlock, HistoryStream m)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT HistoryFailure m (Maybe (HistoryBlock, HistoryStream m))
 -> m (Either
         HistoryFailure (Maybe (HistoryBlock, HistoryStream m))))
-> ExceptT HistoryFailure m (Maybe (HistoryBlock, HistoryStream m))
-> m (Either
        HistoryFailure (Maybe (HistoryBlock, HistoryStream m)))
forall a b. (a -> b) -> a -> b
$ do
        available <- [AssetTx]
-> Maybe (m (Either ClientFailure (Page m AssetTx)))
-> ExceptT
     HistoryFailure
     m
     (Maybe
        (NonEmpty AssetTx,
         Maybe (m (Either ClientFailure (Page m AssetTx)))))
forall {m :: * -> *} {a}.
Monad m =>
[a]
-> Maybe (m (Either ClientFailure (Page m a)))
-> ExceptT
     HistoryFailure
     m
     (Maybe (NonEmpty a, Maybe (m (Either ClientFailure (Page m a)))))
fill [AssetTx]
rows Maybe (m (Either ClientFailure (Page m AssetTx)))
more
        case available of
            Maybe
  (NonEmpty AssetTx,
   Maybe (m (Either ClientFailure (Page m AssetTx))))
Nothing -> Maybe (HistoryBlock, HistoryStream m)
-> ExceptT HistoryFailure m (Maybe (HistoryBlock, HistoryStream m))
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (HistoryBlock, HistoryStream m)
forall a. Maybe a
Nothing
            Just (NonEmpty AssetTx
rows', Maybe (m (Either ClientFailure (Page m AssetTx)))
more') -> do
                let firstRow :: AssetTx
firstRow = NonEmpty AssetTx -> AssetTx
forall a. NonEmpty a -> a
NE.head NonEmpty AssetTx
rows'
                    height :: Word64
height = AssetTx -> Word64
Wire.assetTxBlockHeight AssetTx
firstRow
                case [Word64]
previous of
                    Word64
h : [Word64]
_ | Word64
height Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
h -> HistoryFailure -> ExceptT HistoryFailure m ()
forall a. HistoryFailure -> ExceptT HistoryFailure m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Word64 -> Word64 -> HistoryFailure
HistoryOrderMismatch Word64
h Word64
height)
                    [Word64]
_ -> () -> ExceptT HistoryFailure m ()
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                if Bool -> (Word64 -> Bool) -> Maybe Word64 -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Word64
height Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>) (HistoryRange -> Maybe Word64
throughHeight HistoryRange
range)
                    then Maybe (HistoryBlock, HistoryStream m)
-> ExceptT HistoryFailure m (Maybe (HistoryBlock, HistoryStream m))
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (HistoryBlock, HistoryStream m)
forall a. Maybe a
Nothing
                    else do
                        (blockRows, remaining, continuation) <-
                            Word64
-> [AssetTx]
-> [AssetTx]
-> Maybe (m (Either ClientFailure (Page m AssetTx)))
-> ExceptT
     HistoryFailure
     m
     ([AssetTx], [AssetTx],
      Maybe (m (Either ClientFailure (Page m AssetTx))))
forall {m :: * -> *}.
Monad m =>
Word64
-> [AssetTx]
-> [AssetTx]
-> Maybe (m (Either ClientFailure (Page m AssetTx)))
-> ExceptT
     HistoryFailure
     m
     ([AssetTx], [AssetTx],
      Maybe (m (Either ClientFailure (Page m AssetTx))))
whole Word64
height [] (NonEmpty AssetTx -> [AssetTx]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty AssetTx
rows') Maybe (m (Either ClientFailure (Page m AssetTx)))
more'
                        if maybe False (height <) (fromHeight range)
                            then
                                ExceptT (nextBlock (stream spent [height] remaining continuation))
                            else do
                                complete <- case NE.nonEmpty blockRows of
                                    Maybe (NonEmpty AssetTx)
Nothing ->
                                        HistoryFailure -> ExceptT HistoryFailure m (NonEmpty AssetTx)
forall a. HistoryFailure -> ExceptT HistoryFailure m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                                            (TxId -> Text -> HistoryFailure
HistoryMaterialMismatch (AssetTx -> TxId
Wire.assetTxId AssetTx
firstRow) Text
"empty block")
                                    Just NonEmpty AssetTx
nonempty -> NonEmpty AssetTx -> ExceptT HistoryFailure m (NonEmpty AssetTx)
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty AssetTx
nonempty
                                block <- reconstruct client asset height complete
                                let inputs =
                                        (HistoricalTransaction -> [TxIn])
-> [HistoricalTransaction] -> [TxIn]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                                            (((TxIn, BabbageTxOut ConwayEra) -> TxIn)
-> [(TxIn, BabbageTxOut ConwayEra)] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst ([(TxIn, BabbageTxOut ConwayEra)] -> [TxIn])
-> (HistoricalTransaction -> [(TxIn, BabbageTxOut ConwayEra)])
-> HistoricalTransaction
-> [TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HistoricalTransaction -> Outputs
HistoricalTransaction -> [(TxIn, BabbageTxOut ConwayEra)]
spentOutputs)
                                            ((HistoricalTransaction -> Bool)
-> [HistoricalTransaction] -> [HistoricalTransaction]
forall a. (a -> Bool) -> [a] -> [a]
filter HistoricalTransaction -> Bool
scriptValid (NonEmpty HistoricalTransaction -> [HistoricalTransaction]
forall a. NonEmpty a -> [a]
NE.toList (HistoryBlock -> NonEmpty HistoricalTransaction
blockTransactions HistoryBlock
block)))
                                spent' <- ExceptT . pure $ foldInputs spent inputs
                                pure (Just (block, stream spent' [height] remaining continuation))

    fill :: [a]
-> Maybe (m (Either ClientFailure (Page m a)))
-> ExceptT
     HistoryFailure
     m
     (Maybe (NonEmpty a, Maybe (m (Either ClientFailure (Page m a)))))
fill [] Maybe (m (Either ClientFailure (Page m a)))
Nothing = Maybe (NonEmpty a, Maybe (m (Either ClientFailure (Page m a))))
-> ExceptT
     HistoryFailure
     m
     (Maybe (NonEmpty a, Maybe (m (Either ClientFailure (Page m a)))))
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (NonEmpty a, Maybe (m (Either ClientFailure (Page m a))))
forall a. Maybe a
Nothing
    fill [] (Just m (Either ClientFailure (Page m a))
action) = do
        page <- m (Either HistoryFailure (Page m a))
-> ExceptT HistoryFailure m (Page m a)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((Either ClientFailure (Page m a)
 -> Either HistoryFailure (Page m a))
-> m (Either ClientFailure (Page m a))
-> m (Either HistoryFailure (Page m a))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ClientFailure -> HistoryFailure)
-> Either ClientFailure (Page m a)
-> Either HistoryFailure (Page m a)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ClientFailure -> HistoryFailure
readFailure) m (Either ClientFailure (Page m a))
action)
        fill (Client.pageRows page) (Client.nextPage page)
    fill (a
row : [a]
rows) Maybe (m (Either ClientFailure (Page m a)))
more = Maybe (NonEmpty a, Maybe (m (Either ClientFailure (Page m a))))
-> ExceptT
     HistoryFailure
     m
     (Maybe (NonEmpty a, Maybe (m (Either ClientFailure (Page m a)))))
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((NonEmpty a, Maybe (m (Either ClientFailure (Page m a))))
-> Maybe (NonEmpty a, Maybe (m (Either ClientFailure (Page m a))))
forall a. a -> Maybe a
Just (a
row a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
NE.:| [a]
rows, Maybe (m (Either ClientFailure (Page m a)))
more))

    whole :: Word64
-> [AssetTx]
-> [AssetTx]
-> Maybe (m (Either ClientFailure (Page m AssetTx)))
-> ExceptT
     HistoryFailure
     m
     ([AssetTx], [AssetTx],
      Maybe (m (Either ClientFailure (Page m AssetTx))))
whole Word64
height [AssetTx]
acc [AssetTx]
rows Maybe (m (Either ClientFailure (Page m AssetTx)))
more = do
        let ([AssetTx]
here, [AssetTx]
rest) = (AssetTx -> Bool) -> [AssetTx] -> ([AssetTx], [AssetTx])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
height) (Word64 -> Bool) -> (AssetTx -> Word64) -> AssetTx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssetTx -> Word64
Wire.assetTxBlockHeight) [AssetTx]
rows
            acc' :: [AssetTx]
acc' = [AssetTx]
acc [AssetTx] -> [AssetTx] -> [AssetTx]
forall a. Semigroup a => a -> a -> a
<> [AssetTx]
here
        case [AssetTx]
rest of
            AssetTx
_ : [AssetTx]
_ -> ([AssetTx], [AssetTx],
 Maybe (m (Either ClientFailure (Page m AssetTx))))
-> ExceptT
     HistoryFailure
     m
     ([AssetTx], [AssetTx],
      Maybe (m (Either ClientFailure (Page m AssetTx))))
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([AssetTx]
acc', [AssetTx]
rest, Maybe (m (Either ClientFailure (Page m AssetTx)))
more)
            [] ->
                [AssetTx]
-> Maybe (m (Either ClientFailure (Page m AssetTx)))
-> ExceptT
     HistoryFailure
     m
     (Maybe
        (NonEmpty AssetTx,
         Maybe (m (Either ClientFailure (Page m AssetTx)))))
forall {m :: * -> *} {a}.
Monad m =>
[a]
-> Maybe (m (Either ClientFailure (Page m a)))
-> ExceptT
     HistoryFailure
     m
     (Maybe (NonEmpty a, Maybe (m (Either ClientFailure (Page m a)))))
fill [] Maybe (m (Either ClientFailure (Page m AssetTx)))
more ExceptT
  HistoryFailure
  m
  (Maybe
     (NonEmpty AssetTx,
      Maybe (m (Either ClientFailure (Page m AssetTx)))))
-> (Maybe
      (NonEmpty AssetTx,
       Maybe (m (Either ClientFailure (Page m AssetTx))))
    -> ExceptT
         HistoryFailure
         m
         ([AssetTx], [AssetTx],
          Maybe (m (Either ClientFailure (Page m AssetTx)))))
-> ExceptT
     HistoryFailure
     m
     ([AssetTx], [AssetTx],
      Maybe (m (Either ClientFailure (Page m AssetTx))))
forall a b.
ExceptT HistoryFailure m a
-> (a -> ExceptT HistoryFailure m b) -> ExceptT HistoryFailure m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Maybe
  (NonEmpty AssetTx,
   Maybe (m (Either ClientFailure (Page m AssetTx))))
Nothing -> ([AssetTx], [AssetTx],
 Maybe (m (Either ClientFailure (Page m AssetTx))))
-> ExceptT
     HistoryFailure
     m
     ([AssetTx], [AssetTx],
      Maybe (m (Either ClientFailure (Page m AssetTx))))
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([AssetTx]
acc', [], Maybe (m (Either ClientFailure (Page m AssetTx)))
forall a. Maybe a
Nothing)
                    Just (NonEmpty AssetTx
nextRows, Maybe (m (Either ClientFailure (Page m AssetTx)))
nextMore) -> Word64
-> [AssetTx]
-> [AssetTx]
-> Maybe (m (Either ClientFailure (Page m AssetTx)))
-> ExceptT
     HistoryFailure
     m
     ([AssetTx], [AssetTx],
      Maybe (m (Either ClientFailure (Page m AssetTx))))
whole Word64
height [AssetTx]
acc' (NonEmpty AssetTx -> [AssetTx]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty AssetTx
nextRows) Maybe (m (Either ClientFailure (Page m AssetTx)))
nextMore

readFailure :: Client.ClientFailure -> HistoryFailure
readFailure :: ClientFailure -> HistoryFailure
readFailure = ReadFailure -> HistoryFailure
HistoryReadFailure (ReadFailure -> HistoryFailure)
-> (ClientFailure -> ReadFailure)
-> ClientFailure
-> HistoryFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ReadFailure
BackendReadFailure (Text -> ReadFailure)
-> (ClientFailure -> Text) -> ClientFailure -> ReadFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (ClientFailure -> String) -> ClientFailure -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientFailure -> String
forall a. Show a => a -> String
show

foldInputs
    :: Set.Set TxIn -> [TxIn] -> Either HistoryFailure (Set.Set TxIn)
foldInputs :: Set TxIn -> [TxIn] -> Either HistoryFailure (Set TxIn)
foldInputs = (Either HistoryFailure (Set TxIn)
 -> TxIn -> Either HistoryFailure (Set TxIn))
-> Either HistoryFailure (Set TxIn)
-> [TxIn]
-> Either HistoryFailure (Set TxIn)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Either HistoryFailure (Set TxIn)
-> TxIn -> Either HistoryFailure (Set TxIn)
step (Either HistoryFailure (Set TxIn)
 -> [TxIn] -> Either HistoryFailure (Set TxIn))
-> (Set TxIn -> Either HistoryFailure (Set TxIn))
-> Set TxIn
-> [TxIn]
-> Either HistoryFailure (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TxIn -> Either HistoryFailure (Set TxIn)
forall a b. b -> Either a b
Right
  where
    step :: Either HistoryFailure (Set TxIn)
-> TxIn -> Either HistoryFailure (Set TxIn)
step Either HistoryFailure (Set TxIn)
result TxIn
input = do
        seen <- Either HistoryFailure (Set TxIn)
result
        if Set.member input seen
            then Left (DuplicateSpend input)
            else Right (Set.insert input seen)

reconstruct
    :: (Monad m)
    => Client.Koios m
    -> Asset
    -> Word64
    -> NE.NonEmpty Wire.AssetTx
    -> ExceptT HistoryFailure m HistoryBlock
reconstruct :: forall (m :: * -> *).
Monad m =>
Koios m
-> Asset
-> Word64
-> NonEmpty AssetTx
-> ExceptT HistoryFailure m HistoryBlock
reconstruct Koios m
client Asset
asset Word64
height NonEmpty AssetTx
rows = do
    let ids :: [TxId]
ids = (AssetTx -> TxId) -> [AssetTx] -> [TxId]
forall a b. (a -> b) -> [a] -> [b]
map AssetTx -> TxId
Wire.assetTxId (NonEmpty AssetTx -> [AssetTx]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty AssetTx
rows)
        firstId :: TxId
firstId = AssetTx -> TxId
Wire.assetTxId (NonEmpty AssetTx -> AssetTx
forall a. NonEmpty a -> a
NE.head NonEmpty AssetTx
rows)
    Bool -> ExceptT HistoryFailure m () -> ExceptT HistoryFailure m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TxId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxId]
ids Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set TxId -> Int
forall a. Set a -> Int
Set.size ([TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList [TxId]
ids)) (ExceptT HistoryFailure m () -> ExceptT HistoryFailure m ())
-> ExceptT HistoryFailure m () -> ExceptT HistoryFailure m ()
forall a b. (a -> b) -> a -> b
$
        HistoryFailure -> ExceptT HistoryFailure m ()
forall a. HistoryFailure -> ExceptT HistoryFailure m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
            (TxId -> Text -> HistoryFailure
HistoryMaterialMismatch TxId
firstId Text
"duplicate transaction in listing")
    infos <- m (Either HistoryFailure [TxInfo])
-> ExceptT HistoryFailure m [TxInfo]
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((Either ClientFailure [TxInfo] -> Either HistoryFailure [TxInfo])
-> m (Either ClientFailure [TxInfo])
-> m (Either HistoryFailure [TxInfo])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ClientFailure -> HistoryFailure)
-> Either ClientFailure [TxInfo] -> Either HistoryFailure [TxInfo]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ClientFailure -> HistoryFailure
readFailure) (Koios m -> [TxId] -> m (Either ClientFailure [TxInfo])
forall (m :: * -> *).
Monad m =>
Koios m -> [TxId] -> m (Either ClientFailure [TxInfo])
Client.txInfo Koios m
client [TxId]
ids))
    let known = [(TxId, TxInfo)] -> Map TxId TxInfo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxInfo -> TxId
Wire.txInfoId TxInfo
info, TxInfo
info) | TxInfo
info <- [TxInfo]
infos]
        dependencies TxInfo
info =
            [ TxId
parent
            | (TxIn TxId
parent TxIx
_, BabbageTxOut ConwayEra
output) <- TxInfo -> Outputs
Wire.txInfoInputs TxInfo
info
            , Asset -> TxOut ConwayEra -> Bool
holds Asset
asset TxOut ConwayEra
BabbageTxOut ConwayEra
output
            ]
    -- Only missing asset-carrying creators are looked up. In particular a
    -- same-block funding creator without the asset causes no extra request.
    forInputs <- traverse (checkParents known dependencies) infos
    ordered <- ExceptT . pure $ topological forInputs
    cbors <-
        ExceptT
            ( fmap
                (first readFailure)
                (Client.txCbor client (map Wire.txInfoId ordered))
            )
    material <-
        ExceptT . pure $ traverse (uncurry materialOf) (zip ordered cbors)
    let allOutputs = [(TxIn, BabbageTxOut ConwayEra)]
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((HistoricalTransaction -> [(TxIn, BabbageTxOut ConwayEra)])
-> [HistoricalTransaction] -> [(TxIn, BabbageTxOut ConwayEra)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HistoricalTransaction -> Outputs
HistoricalTransaction -> [(TxIn, BabbageTxOut ConwayEra)]
createdOutputs [HistoricalTransaction]
material)
    mapM_ (checkResolved allOutputs) material
    case NE.nonEmpty material of
        Maybe (NonEmpty HistoricalTransaction)
Nothing -> HistoryFailure -> ExceptT HistoryFailure m HistoryBlock
forall a. HistoryFailure -> ExceptT HistoryFailure m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TxId -> Text -> HistoryFailure
HistoryMaterialMismatch TxId
firstId Text
"empty block")
        Just NonEmpty HistoricalTransaction
transactions -> HistoryBlock -> ExceptT HistoryFailure m HistoryBlock
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> NonEmpty HistoricalTransaction -> HistoryBlock
HistoryBlock Word64
height NonEmpty HistoricalTransaction
transactions)
  where
    checkParents :: Map TxId a
-> (TxInfo -> [TxId])
-> TxInfo
-> ExceptT HistoryFailure m (TxInfo, Set TxId)
checkParents Map TxId a
known TxInfo -> [TxId]
dependencies TxInfo
info = do
        Bool -> ExceptT HistoryFailure m () -> ExceptT HistoryFailure m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TxInfo -> Word64
Wire.txInfoBlockHeight TxInfo
info Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
height) (ExceptT HistoryFailure m () -> ExceptT HistoryFailure m ())
-> ExceptT HistoryFailure m () -> ExceptT HistoryFailure m ()
forall a b. (a -> b) -> a -> b
$
            HistoryFailure -> ExceptT HistoryFailure m ()
forall a. HistoryFailure -> ExceptT HistoryFailure m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                ( TxId -> Text -> HistoryFailure
HistoryMaterialMismatch
                    (TxInfo -> TxId
Wire.txInfoId TxInfo
info)
                    Text
"listing and transaction heights disagree"
                )
        let absent :: [TxId]
absent =
                Set TxId -> [TxId]
forall a. Set a -> [a]
Set.toList ([TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList (TxInfo -> [TxId]
dependencies TxInfo
info) Set TxId -> Set TxId -> Set TxId
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Map TxId a -> Set TxId
forall k a. Map k a -> Set k
Map.keysSet Map TxId a
known)
        parents <-
            if [TxId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxId]
absent
                then [TxInfo] -> ExceptT HistoryFailure m [TxInfo]
forall a. a -> ExceptT HistoryFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                else m (Either HistoryFailure [TxInfo])
-> ExceptT HistoryFailure m [TxInfo]
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((Either ClientFailure [TxInfo] -> Either HistoryFailure [TxInfo])
-> m (Either ClientFailure [TxInfo])
-> m (Either HistoryFailure [TxInfo])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ClientFailure -> HistoryFailure)
-> Either ClientFailure [TxInfo] -> Either HistoryFailure [TxInfo]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ClientFailure -> HistoryFailure
readFailure) (Koios m -> [TxId] -> m (Either ClientFailure [TxInfo])
forall (m :: * -> *).
Monad m =>
Koios m -> [TxId] -> m (Either ClientFailure [TxInfo])
Client.txInfo Koios m
client [TxId]
absent))
        mapM_
            ( \TxInfo
parent ->
                Bool -> ExceptT HistoryFailure m () -> ExceptT HistoryFailure m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TxInfo -> Word64
Wire.txInfoBlockHeight TxInfo
parent Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
height) (ExceptT HistoryFailure m () -> ExceptT HistoryFailure m ())
-> ExceptT HistoryFailure m () -> ExceptT HistoryFailure m ()
forall a b. (a -> b) -> a -> b
$
                    HistoryFailure -> ExceptT HistoryFailure m ()
forall a. HistoryFailure -> ExceptT HistoryFailure m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                        (TxId -> TxId -> HistoryFailure
MissingInBlockParent (TxInfo -> TxId
Wire.txInfoId TxInfo
info) (TxInfo -> TxId
Wire.txInfoId TxInfo
parent))
            )
            parents
        -- An asset-carrying creator outside this block can be outside the
        -- requested height range. Check its actual body without adding a row
        -- or fetching unrelated funding/collateral/fee creators.
        parentBodies <-
            if null absent
                then pure []
                else ExceptT (fmap (first readFailure) (Client.txCbor client absent))
        mapM_ (checkEarlierParent info) parentBodies
        pure
            ( info
            , Set.fromList (dependencies info) `Set.intersection` Map.keysSet known
            )
    checkEarlierParent :: TxInfo -> TxCbor -> m ()
checkEarlierParent TxInfo
info TxCbor
parent = do
        let key :: TxId
key = TxCbor -> TxId
Wire.txCborId TxCbor
parent
            produced :: Map TxIn (BabbageTxOut ConwayEra)
produced =
                [(TxIn, BabbageTxOut ConwayEra)]
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                    ( (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 TxId
key (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 (TxCbor -> ConwayTx
Wire.txCborTx TxCbor
parent 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))
                    )
        ((TxIn, BabbageTxOut ConwayEra) -> m ())
-> [(TxIn, BabbageTxOut ConwayEra)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
            ( \(reference :: TxIn
reference@(TxIn TxId
creator TxIx
_), BabbageTxOut ConwayEra
output) ->
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.when (TxId
creator TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxId
key Bool -> Bool -> Bool
&& Asset -> TxOut ConwayEra -> Bool
holds Asset
asset TxOut ConwayEra
BabbageTxOut ConwayEra
output)
                    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
                        ( TxCbor -> Bool
Wire.txCborValid TxCbor
parent
                            Bool -> Bool -> Bool
&& TxIn
-> Map TxIn (BabbageTxOut ConwayEra)
-> Maybe (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
reference Map TxIn (BabbageTxOut ConwayEra)
produced Maybe (BabbageTxOut ConwayEra)
-> Maybe (BabbageTxOut ConwayEra) -> Bool
forall a. Eq a => a -> a -> Bool
== BabbageTxOut ConwayEra -> Maybe (BabbageTxOut ConwayEra)
forall a. a -> Maybe a
Just BabbageTxOut ConwayEra
output
                        )
                    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ HistoryFailure -> m ()
forall a. HistoryFailure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                        ( TxId -> Text -> HistoryFailure
HistoryMaterialMismatch
                            (TxInfo -> TxId
Wire.txInfoId TxInfo
info)
                            Text
"resolved earlier asset output"
                        )
            )
            (TxInfo -> Outputs
Wire.txInfoInputs TxInfo
info)

{- | Deterministic Kahn order. Hash order breaks ties only among transactions
whose selected-asset ancestors have already been emitted.
-}
topological
    :: [(Wire.TxInfo, Set.Set TxId)] -> Either HistoryFailure [Wire.TxInfo]
topological :: [(TxInfo, Set TxId)] -> Either HistoryFailure [TxInfo]
topological = [TxInfo] -> [(TxInfo, Set TxId)] -> Either HistoryFailure [TxInfo]
go []
  where
    go :: [TxInfo] -> [(TxInfo, Set TxId)] -> Either HistoryFailure [TxInfo]
go [TxInfo]
done [] = [TxInfo] -> Either HistoryFailure [TxInfo]
forall a b. b -> Either a b
Right ([TxInfo] -> [TxInfo]
forall a. [a] -> [a]
reverse [TxInfo]
done)
    go [TxInfo]
done [(TxInfo, Set TxId)]
remaining =
        case ((TxInfo, Set TxId) -> TxId)
-> [(TxInfo, Set TxId)] -> [(TxInfo, Set TxId)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TxInfo -> TxId
Wire.txInfoId (TxInfo -> TxId)
-> ((TxInfo, Set TxId) -> TxInfo) -> (TxInfo, Set TxId) -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxInfo, Set TxId) -> TxInfo
forall a b. (a, b) -> a
fst) (((TxInfo, Set TxId) -> Bool)
-> [(TxInfo, Set TxId)] -> [(TxInfo, Set TxId)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Set TxId -> Bool
forall a. Set a -> Bool
Set.null (Set TxId -> Bool)
-> ((TxInfo, Set TxId) -> Set TxId) -> (TxInfo, Set TxId) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxInfo, Set TxId) -> Set TxId
forall a b. (a, b) -> b
snd) [(TxInfo, Set TxId)]
remaining) of
            [] ->
                HistoryFailure -> Either HistoryFailure [TxInfo]
forall a b. a -> Either a b
Left
                    ( NonEmpty TxId -> HistoryFailure
HistoryDependencyCycle
                        ([TxId] -> NonEmpty TxId
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (((TxInfo, Set TxId) -> TxId) -> [(TxInfo, Set TxId)] -> [TxId]
forall a b. (a -> b) -> [a] -> [b]
map (TxInfo -> TxId
Wire.txInfoId (TxInfo -> TxId)
-> ((TxInfo, Set TxId) -> TxInfo) -> (TxInfo, Set TxId) -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxInfo, Set TxId) -> TxInfo
forall a b. (a, b) -> a
fst) [(TxInfo, Set TxId)]
remaining))
                    )
            (TxInfo
info, Set TxId
_) : [(TxInfo, Set TxId)]
_ ->
                let key :: TxId
key = TxInfo -> TxId
Wire.txInfoId TxInfo
info
                in  [TxInfo] -> [(TxInfo, Set TxId)] -> Either HistoryFailure [TxInfo]
go
                        (TxInfo
info TxInfo -> [TxInfo] -> [TxInfo]
forall a. a -> [a] -> [a]
: [TxInfo]
done)
                        [ (TxInfo
other, TxId -> Set TxId -> Set TxId
forall a. Ord a => a -> Set a -> Set a
Set.delete TxId
key Set TxId
parents)
                        | (TxInfo
other, Set TxId
parents) <- [(TxInfo, Set TxId)]
remaining
                        , TxInfo -> TxId
Wire.txInfoId TxInfo
other TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
/= TxId
key
                        ]

holds :: 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

materialOf
    :: Wire.TxInfo
    -> Wire.TxCbor
    -> Either HistoryFailure HistoricalTransaction
materialOf :: TxInfo -> TxCbor -> Either HistoryFailure HistoricalTransaction
materialOf TxInfo
info TxCbor
cbor = do
    let tx :: ConwayTx
tx = TxCbor -> ConwayTx
Wire.txCborTx TxCbor
cbor
        body :: TxBody TopTx ConwayEra
body = ConwayTx
tx ConwayTx
-> Getting
     (TxBody TopTx ConwayEra) ConwayTx (TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx ConwayEra) ConwayTx (TxBody 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
        key :: TxId
key = TxInfo -> TxId
Wire.txInfoId TxInfo
info
        refuse :: Text -> Either HistoryFailure b
refuse Text
message = HistoryFailure -> Either HistoryFailure b
forall a b. a -> Either a b
Left (TxId -> Text -> HistoryFailure
HistoryMaterialMismatch TxId
key Text
message)
        produced :: [(TxIn, BabbageTxOut ConwayEra)]
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 TxId
key (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 (TxBody TopTx ConwayEra
body TxBody TopTx ConwayEra
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (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))
        exactInputs :: [(a, b)] -> Set a -> Bool
exactInputs [(a, b)]
outputs Set a
refs =
            [(a, b)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, b)]
outputs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set a -> Int
forall a. Set a -> Int
Set.size Set a
refs
                Bool -> Bool -> Bool
&& [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
outputs) Set a -> Set a -> Bool
forall a. Eq a => a -> a -> Bool
== Set a
refs
    Bool -> Either HistoryFailure () -> Either HistoryFailure ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (TxId
key TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxCbor -> TxId
Wire.txCborId TxCbor
cbor)
        (Text -> Either HistoryFailure ()
forall {b}. Text -> Either HistoryFailure b
refuse Text
"CBOR transaction identity")
    Bool -> Either HistoryFailure () -> Either HistoryFailure ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (TxInfo -> Bool
Wire.txInfoValid TxInfo
info Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== TxCbor -> Bool
Wire.txCborValid TxCbor
cbor)
        (Text -> Either HistoryFailure ()
forall {b}. Text -> Either HistoryFailure b
refuse Text
"script validity")
    Bool -> Either HistoryFailure () -> Either HistoryFailure ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        ([(TxIn, BabbageTxOut ConwayEra)] -> Set TxIn -> Bool
forall {a} {b}. Ord a => [(a, b)] -> Set a -> Bool
exactInputs (TxInfo -> Outputs
Wire.txInfoInputs TxInfo
info) (TxBody TopTx ConwayEra
body TxBody TopTx ConwayEra
-> Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
-> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL))
        (Text -> Either HistoryFailure ()
forall {b}. Text -> Either HistoryFailure b
refuse Text
"spent input references")
    Bool -> Either HistoryFailure () -> Either HistoryFailure ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        ( [(TxIn, BabbageTxOut ConwayEra)] -> Set TxIn -> Bool
forall {a} {b}. Ord a => [(a, b)] -> Set a -> Bool
exactInputs
            (TxInfo -> Outputs
Wire.txInfoReferenceInputs TxInfo
info)
            (TxBody TopTx ConwayEra
body TxBody TopTx ConwayEra
-> Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
-> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx ConwayEra) (Set TxIn)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
referenceInputsTxBodyL)
        )
        (Text -> Either HistoryFailure ()
forall {b}. Text -> Either HistoryFailure b
refuse Text
"reference input references")
    Bool -> Either HistoryFailure () -> Either HistoryFailure ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        ( [(TxIn, BabbageTxOut ConwayEra)]
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn, BabbageTxOut ConwayEra)]
produced Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra) -> Bool
forall a. Eq a => a -> a -> Bool
== [(TxIn, BabbageTxOut ConwayEra)]
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (TxInfo -> Outputs
Wire.txInfoOutputs TxInfo
info)
            Bool -> Bool -> Bool
&& [(TxIn, BabbageTxOut ConwayEra)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxIn, BabbageTxOut ConwayEra)]
produced Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(TxIn, BabbageTxOut ConwayEra)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxInfo -> Outputs
Wire.txInfoOutputs TxInfo
info)
        )
        (Text -> Either HistoryFailure ()
forall {b}. Text -> Either HistoryFailure b
refuse Text
"produced outputs")
    HistoricalTransaction
-> Either HistoryFailure HistoricalTransaction
forall a. a -> Either HistoryFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        HistoricalTransaction
            { historicalId :: TxId
historicalId = TxId
key
            , historicalCbor :: ByteString
historicalCbor = TxCbor -> ByteString
Wire.txCborBytes TxCbor
cbor
            , historicalTx :: ConwayTx
historicalTx = ConwayTx
tx
            , spentOutputs :: Outputs
spentOutputs = TxInfo -> Outputs
Wire.txInfoInputs TxInfo
info
            , referenceOutputs :: Outputs
referenceOutputs = TxInfo -> Outputs
Wire.txInfoReferenceInputs TxInfo
info
            , createdOutputs :: Outputs
createdOutputs = Outputs
[(TxIn, BabbageTxOut ConwayEra)]
produced
            , scriptValid :: Bool
scriptValid = TxCbor -> Bool
Wire.txCborValid TxCbor
cbor
            }

checkResolved
    :: (Monad m)
    => Map.Map TxIn (TxOut ConwayEra)
    -> HistoricalTransaction
    -> ExceptT HistoryFailure m ()
checkResolved :: forall (m :: * -> *).
Monad m =>
Map TxIn (TxOut ConwayEra)
-> HistoricalTransaction -> ExceptT HistoryFailure m ()
checkResolved Map TxIn (TxOut ConwayEra)
allOutputs HistoricalTransaction
transaction =
    ((TxIn, BabbageTxOut ConwayEra) -> ExceptT HistoryFailure m ())
-> [(TxIn, BabbageTxOut ConwayEra)] -> ExceptT HistoryFailure m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TxIn, BabbageTxOut ConwayEra) -> ExceptT HistoryFailure m ()
forall {m :: * -> *}.
MonadError HistoryFailure m =>
(TxIn, BabbageTxOut ConwayEra) -> m ()
check (HistoricalTransaction -> Outputs
spentOutputs HistoricalTransaction
transaction [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall a. Semigroup a => a -> a -> a
<> HistoricalTransaction -> Outputs
referenceOutputs HistoricalTransaction
transaction)
  where
    check :: (TxIn, BabbageTxOut ConwayEra) -> m ()
check (TxIn
reference, BabbageTxOut ConwayEra
output) = case TxIn
-> Map TxIn (BabbageTxOut ConwayEra)
-> Maybe (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
reference Map TxIn (TxOut ConwayEra)
Map TxIn (BabbageTxOut ConwayEra)
allOutputs of
        Just BabbageTxOut ConwayEra
created
            | BabbageTxOut ConwayEra
created BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra -> Bool
forall a. Eq a => a -> a -> Bool
/= BabbageTxOut ConwayEra
output ->
                HistoryFailure -> m ()
forall a. HistoryFailure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                    ( TxId -> Text -> HistoryFailure
HistoryMaterialMismatch
                        (HistoricalTransaction -> TxId
historicalId HistoricalTransaction
transaction)
                        Text
"resolved in-block output"
                    )
        Maybe (BabbageTxOut ConwayEra)
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()