{- |
Module      : Singular.Registry.TxBuilder.Update.Context
Description : Fold context preparation — queries, proofs, state and slot
License     : Apache-2.0

Everything a fold must know or prepare before it can decide anything:
the registry context a caller hands in (and its empty value), the
state/request/fee queries that find the fold's inputs, the ordered
speculative proofs through the trie, the state continuation output and
its script, the validity upper slot, and the completion of a partly
empty context from the provider.

This module owns no duty decisions and no transaction assembly; see
"Singular.Registry.TxBuilder.Update.Duties" and
"Singular.Registry.TxBuilder.Update.Build". The public surface stays
"Singular.Registry.TxBuilder.Update", which re-exports the context
types unchanged (#267).
-}
module Singular.Registry.TxBuilder.Update.Context
    ( RegistryContext (..)
    , HolderRelease (..)
    , emptyRegistryContext
    , completeContext
    , queryContext
    , computeProofs
    , prepareState
    , computeUpperSlot
    ) where

import Control.Monad (when)
import Data.ByteString (ByteString)
import Data.List (sortOn)
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Ord (Down (..))
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.POSIX
    ( utcTimeToPOSIXSeconds
    )
import Lens.Micro ((&), (.~), (^.))
import PlutusCore.Data qualified as PLC

import Cardano.Ledger.Address (Addr)
import Cardano.Ledger.Api.Tx.Out
    ( TxOut
    , coinTxOutL
    , datumTxOutL
    , mkBasicTxOut
    , referenceScriptTxOutL
    , valueTxOutL
    )
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Core (Script)
import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..))
import Cardano.Slotting.Slot (SlotNo)

import Singular.Registry.Config
    ( CageConfig (..)
    )
import Singular.Registry.Evidence (NoWitness)
import Singular.Registry.Ledger
    ( ConwayEra
    , PParams
    , Root (..)
    , TokenId
    , TxIn
    )
import Singular.Registry.LedgerProvider (Session, TipObservation (..))
import Singular.Registry.SessionIO (outputsAt, parameters)
import Singular.Registry.SessionIO qualified as Services
import Singular.Registry.Trie
    ( Trie (..)
    , TrieManager (..)
    )
import Singular.Registry.TxBuilder.Internal.Edges
import Singular.Registry.TxBuilder.Internal.Identity
import Singular.Registry.TxBuilder.Internal.Lookup
import Singular.Registry.Types
    ( CageDatum (..)
    , OnChainRequest (..)
    , OnChainRoot (..)
    , OnChainTokenState (..)
    , ProofStep
    )

{- | What a fold needs in hand to discharge the obligations: the three
token policies' scripts by kind, the cage script (custody spends run it),
and the UTxOs sitting at the cage address (custody lives among them). A
delivered output's datum is the one its request carries (#419), so nothing
beyond the chain is in hand.
-}
data RegistryContext = RegistryContext
    { RegistryContext -> Map Integer (Script ConwayEra)
rcWitnessScripts :: Map.Map Integer (Script ConwayEra)
    , RegistryContext -> Maybe (Script ConwayEra)
rcCageScript :: Maybe (Script ConwayEra)
    , RegistryContext -> [(TxIn, TxOut ConwayEra)]
rcCageUtxos :: [(TxIn, TxOut ConwayEra)]
    , RegistryContext -> Bool
rcAllowInadmissible :: Bool
    {- ^ Build a fold even when a request takes no admissible edge, so a
    row that exists to watch the chain REFUSE one can produce the
    transaction it submits. An honest builder leaves this off and
    fails early, naming the request.
    -}
    , RegistryContext -> [(TxIn, TxOut ConwayEra)]
rcHolderUtxos :: [(TxIn, TxOut ConwayEra)]
    {- ^ #177 I177-BUILDER: the candidate inputs a burn may be sourced
    from — the outputs that actually HOLD registry witnesses. A
    retirement or an active deletion destroys an asset it does not
    create, so the fold has to consume the holder's own UTxO; with
    nothing in this
    inventory the builder fails naming the key rather than emitting a
    mint the cage refuses `token-missing`. Left empty, the builder
    queries the fold's own wallet address.
    -}
    , RegistryContext -> Map TxIn HolderRelease
rcHolderReleases :: Map.Map TxIn HolderRelease
    {- ^ #299: holders that sit at an application script rather than a
    key. A burn sourced from one of them spends it with the application's
    own witness instead of as a plain input, and the application's
    release is owed to its recipient together with every other
    obligation of the fold to that key. Empty for key-held witnesses.
    -}
    , RegistryContext -> [(TxIn, TxOut ConwayEra)]
rcRefUtxos :: [(TxIn, TxOut ConwayEra)]
    {- ^ Outputs carrying the fold's scripts as reference scripts. The
    state validator alone is fifteen kilobytes, so a fold that
    attaches it, the request script and a token policy does not fit
    in a transaction; with references every purpose resolves through
    them instead.
    -}
    }

{- | How an application-held burn source is spent, and what its spend
releases (#299): the redeemer and script that witness the spend, and the
lovelace owed to the recipient's key because the holder is released.
-}
data HolderRelease = HolderRelease
    { HolderRelease -> Data
hrRedeemer :: PLC.Data
    , HolderRelease -> Script ConwayEra
hrScript :: Script ConwayEra
    , HolderRelease -> ByteString
hrRecipient :: ByteString
    -- ^ The payment key hash the release is owed to
    , HolderRelease -> Integer
hrReleased :: Integer
    -- ^ Lovelace owed to it, over every other obligation to that key
    }
    deriving stock (HolderRelease -> HolderRelease -> Bool
(HolderRelease -> HolderRelease -> Bool)
-> (HolderRelease -> HolderRelease -> Bool) -> Eq HolderRelease
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HolderRelease -> HolderRelease -> Bool
== :: HolderRelease -> HolderRelease -> Bool
$c/= :: HolderRelease -> HolderRelease -> Bool
/= :: HolderRelease -> HolderRelease -> Bool
Eq, Int -> HolderRelease -> ShowS
[HolderRelease] -> ShowS
HolderRelease -> String
(Int -> HolderRelease -> ShowS)
-> (HolderRelease -> String)
-> ([HolderRelease] -> ShowS)
-> Show HolderRelease
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HolderRelease -> ShowS
showsPrec :: Int -> HolderRelease -> ShowS
$cshow :: HolderRelease -> String
show :: HolderRelease -> String
$cshowList :: [HolderRelease] -> ShowS
showList :: [HolderRelease] -> ShowS
Show)

{- | The context a fold of tree edges needs beyond the registry's own
configuration: the three token policies' scripts and the cage script that
custody spends run. A delivered output's datum is the one its request
carries.

`emptyRegistryContext` carries none of it, which is right for a caller
that folds only rejections — and refuses loudly, naming the missing
script, for one that folds an edge without it.
-}
emptyRegistryContext :: RegistryContext
emptyRegistryContext :: RegistryContext
emptyRegistryContext =
    RegistryContext
        { rcWitnessScripts :: Map Integer (Script ConwayEra)
rcWitnessScripts = Map Integer (AlonzoScript ConwayEra)
Map Integer (Script ConwayEra)
forall k a. Map k a
Map.empty
        , rcCageScript :: Maybe (Script ConwayEra)
rcCageScript = Maybe (AlonzoScript ConwayEra)
Maybe (Script ConwayEra)
forall a. Maybe a
Nothing
        , rcCageUtxos :: [(TxIn, TxOut ConwayEra)]
rcCageUtxos = []
        , rcAllowInadmissible :: Bool
rcAllowInadmissible = Bool
False
        , rcHolderUtxos :: [(TxIn, TxOut ConwayEra)]
rcHolderUtxos = []
        , rcHolderReleases :: Map TxIn HolderRelease
rcHolderReleases = Map TxIn HolderRelease
forall k a. Map k a
Map.empty
        , rcRefUtxos :: [(TxIn, TxOut ConwayEra)]
rcRefUtxos = []
        }

{- | Complete a context the caller left partly empty: the cage's own
UTxOs and the fold's holder inventory are queried from the provider
when the caller did not supply them, and the cage script defaults to
the one this build's own state continuation runs. The caller-supplied
value always wins; only an omission triggers a query (#267: moved
verbatim from the facade's inline completion).
-}
completeContext
    :: CageConfig
    -> Session NoWitness IO
    -> Addr
    -> Script ConwayEra
    -> RegistryContext
    -> IO RegistryContext
completeContext :: CageConfig
-> Session NoWitness IO
-> Addr
-> Script ConwayEra
-> RegistryContext
-> IO RegistryContext
completeContext CageConfig
cfg Session NoWitness IO
view Addr
addr Script ConwayEra
script RegistryContext
ctx0 = do
    -- The cage's own UTxOs are where custody sits; the caller need not
    -- have queried them, and the cage script is this build's own.
    cageUtxos <-
        if [(TxIn, BabbageTxOut ConwayEra)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RegistryContext -> [(TxIn, TxOut ConwayEra)]
rcCageUtxos RegistryContext
ctx0)
            then Session NoWitness IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
forall w. Session w IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
outputsAt Session NoWitness IO
view (CageConfig -> Network -> Addr
cageAddrFromCfg CageConfig
cfg (CageConfig -> Network
network CageConfig
cfg))
            else [(TxIn, BabbageTxOut ConwayEra)]
-> IO [(TxIn, BabbageTxOut ConwayEra)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RegistryContext -> [(TxIn, TxOut ConwayEra)]
rcCageUtxos RegistryContext
ctx0)
    -- #177 I177-BUILDER: the candidate burn sources. A retirement or a
    -- deletion of an active key destroys an asset it does not create,
    -- so the fold has to consume the UTxO that HOLDS it; left unset,
    -- the inventory is the fold's own wallet, which is where
    -- `insertActive` delivered it.
    holderUtxos <-
        if null (rcHolderUtxos ctx0)
            then outputsAt view addr
            else pure (rcHolderUtxos ctx0)
    pure
        ctx0
            { rcCageUtxos = cageUtxos
            , rcHolderUtxos = holderUtxos
            , rcCageScript = case rcCageScript ctx0 of
                Just Script ConwayEra
s -> AlonzoScript ConwayEra -> Maybe (AlonzoScript ConwayEra)
forall a. a -> Maybe a
Just AlonzoScript ConwayEra
Script ConwayEra
s
                Maybe (Script ConwayEra)
Nothing -> AlonzoScript ConwayEra -> Maybe (AlonzoScript ConwayEra)
forall a. a -> Maybe a
Just AlonzoScript ConwayEra
Script ConwayEra
script
            }

{- | Query cage UTxOs, find the state and request
UTxOs, pick a fee-paying wallet UTxO.

The pending-request query takes the chosen set: folding every pending
request (absent selection) still refuses an empty pending set with the
long-standing generic error, while folding a chosen set returns whatever
is pending (possibly none) so the caller can name every chosen reference
that is not among them, at every live pending-set size including zero.
-}
queryContext
    :: Maybe (NE.NonEmpty TxIn)
    -> CageConfig
    -> Session NoWitness IO
    -> TokenId
    -> Addr
    -> IO
        ( (TxIn, TxOut ConwayEra)
        , [(TxIn, TxOut ConwayEra)]
        , (TxIn, TxOut ConwayEra)
        , PParams ConwayEra
        )
queryContext :: Maybe (NonEmpty TxIn)
-> CageConfig
-> Session NoWitness IO
-> TokenId
-> Addr
-> IO
     ((TxIn, TxOut ConwayEra), [(TxIn, TxOut ConwayEra)],
      (TxIn, TxOut ConwayEra), PParams ConwayEra)
queryContext Maybe (NonEmpty TxIn)
selected CageConfig
cfg Session NoWitness IO
view TokenId
tid Addr
addr = do
    let stateAddr :: Addr
stateAddr =
            CageConfig -> Network -> Addr
cageAddrFromCfg CageConfig
cfg (CageConfig -> Network
network CageConfig
cfg)
        reqAddr :: Addr
reqAddr =
            CageConfig -> TokenId -> Network -> Addr
requestAddrFromCfg CageConfig
cfg TokenId
tid (CageConfig -> Network
network CageConfig
cfg)
    stateUtxos <- Session NoWitness IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
forall w. Session w IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
outputsAt Session NoWitness IO
view Addr
stateAddr
    requestUtxos <- outputsAt view reqAddr
    let policyId = CageConfig -> PolicyID
cagePolicyIdFromCfg CageConfig
cfg
    stateUtxo <- case findStateUtxo
        policyId
        tid
        stateUtxos of
        Maybe (TxIn, TxOut ConwayEra)
Nothing ->
            String -> IO (TxIn, BabbageTxOut ConwayEra)
forall a. HasCallStack => String -> a
error
                String
"updateToken: state UTxO \
                \not found"
        Just (TxIn, TxOut ConwayEra)
x -> (TxIn, BabbageTxOut ConwayEra) -> IO (TxIn, BabbageTxOut ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut ConwayEra)
(TxIn, BabbageTxOut ConwayEra)
x
    let reqUtxos =
            ((TxIn, TxOut ConwayEra) -> TxIn)
-> [(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TxIn, TxOut ConwayEra) -> TxIn
(TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst ([(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)])
-> [(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)]
forall a b. (a -> b) -> a -> b
$
                TokenId -> [(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)]
findRequestUtxos TokenId
tid [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
requestUtxos
    case selected of
        Maybe (NonEmpty TxIn)
Nothing ->
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(TxIn, BabbageTxOut ConwayEra)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TxIn, BabbageTxOut ConwayEra)]
reqUtxos) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall a. HasCallStack => String -> a
error String
"updateToken: no pending requests"
        Just NonEmpty TxIn
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    pp <- parameters view
    walletUtxos <- outputsAt view addr
    -- #157: an approval is not burned at the fold, so it returns to the
    -- funder and rides in the wallet from then on. The fee input doubles
    -- as collateral, and collateral must be ada-only.
    feeUtxo <- case sortOn
        (Down . (^. coinTxOutL) . snd)
        (filter (adaOnlyOutput . snd) walletUtxos) of
        [] -> String -> IO (TxIn, BabbageTxOut ConwayEra)
forall a. HasCallStack => String -> a
error String
"updateToken: no ada-only UTxO to fund the fold"
        ((TxIn, BabbageTxOut ConwayEra)
u : [(TxIn, BabbageTxOut ConwayEra)]
_) -> (TxIn, BabbageTxOut ConwayEra) -> IO (TxIn, BabbageTxOut ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, BabbageTxOut ConwayEra)
u
    pure (stateUtxo, reqUtxos, feeUtxo, pp)

{- | Run speculative trie operations to compute
proofs and the new root hash.
-}
computeProofs
    :: TrieManager IO
    -> TokenId
    -> [(TxIn, TxOut ConwayEra)]
    -> IO ([[ProofStep]], Root)
computeProofs :: TrieManager IO
-> TokenId -> [(TxIn, TxOut ConwayEra)] -> IO ([[ProofStep]], Root)
computeProofs TrieManager IO
tm TokenId
tid [(TxIn, TxOut ConwayEra)]
reqUtxos =
    TrieManager IO
-> forall a.
   TokenId -> (forall (n :: * -> *). Monad n => Trie n -> n a) -> IO a
forall (m :: * -> *).
TrieManager m
-> forall a.
   TokenId -> (forall (n :: * -> *). Monad n => Trie n -> n a) -> m a
withSpeculativeTrie TrieManager IO
tm TokenId
tid ((forall (n :: * -> *).
  Monad n =>
  Trie n -> n ([[ProofStep]], Root))
 -> IO ([[ProofStep]], Root))
-> (forall (n :: * -> *).
    Monad n =>
    Trie n -> n ([[ProofStep]], Root))
-> IO ([[ProofStep]], Root)
forall a b. (a -> b) -> a -> b
$ \Trie n
trie -> do
        ps <- ((TxIn, BabbageTxOut ConwayEra) -> n [ProofStep])
-> [(TxIn, BabbageTxOut ConwayEra)] -> n [[ProofStep]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Trie n -> (TxIn, TxOut ConwayEra) -> n [ProofStep]
forall (m :: * -> *).
Monad m =>
Trie m -> (TxIn, TxOut ConwayEra) -> m [ProofStep]
processRequest Trie n
trie) [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
reqUtxos
        r <- getRoot trie
        pure (ps, r)

{- | Extract old state, build new state output,
cage script, and owner key hash.
-}
prepareState
    :: CageConfig
    -> TxOut ConwayEra
    -> Root
    -> (OnChainTokenState, TxOut ConwayEra, Script ConwayEra)
prepareState :: CageConfig
-> TxOut ConwayEra
-> Root
-> (OnChainTokenState, TxOut ConwayEra, Script ConwayEra)
prepareState CageConfig
cfg TxOut ConwayEra
stateOut Root
newRoot =
    let scriptAddr :: Addr
scriptAddr =
            CageConfig -> Network -> Addr
cageAddrFromCfg CageConfig
cfg (CageConfig -> Network
network CageConfig
cfg)
        oldState :: OnChainTokenState
oldState =
            case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
stateOut of
                Just (StateDatum OnChainTokenState
s) -> OnChainTokenState
s
                Maybe CageDatum
_ ->
                    String -> OnChainTokenState
forall a. HasCallStack => String -> a
error
                        String
"updateToken: invalid \
                        \state datum"
        newStateDatum :: CageDatum
newStateDatum =
            OnChainTokenState -> CageDatum
StateDatum
                OnChainTokenState
oldState
                    { stateRoot =
                        OnChainRoot
                            (unRoot newRoot)
                    }
        newStateOut :: BabbageTxOut ConwayEra
newStateOut =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                Addr
scriptAddr
                (TxOut ConwayEra
BabbageTxOut ConwayEra
stateOut BabbageTxOut ConwayEra
-> Getting
     (Value ConwayEra) (BabbageTxOut ConwayEra) (Value ConwayEra)
-> Value ConwayEra
forall s a. s -> Getting a s a -> a
^. (Value ConwayEra -> Const (Value ConwayEra) (Value ConwayEra))
-> TxOut ConwayEra -> Const (Value ConwayEra) (TxOut ConwayEra)
Getting
  (Value ConwayEra) (BabbageTxOut ConwayEra) (Value ConwayEra)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut ConwayEra) (Value ConwayEra)
valueTxOutL)
                TxOut ConwayEra
-> (TxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Datum ConwayEra -> Identity (Datum ConwayEra))
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
(Datum ConwayEra -> Identity (Datum ConwayEra))
-> TxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era. BabbageEraTxOut era => Lens' (TxOut era) (Datum era)
Lens' (TxOut ConwayEra) (Datum ConwayEra)
datumTxOutL
                    ((Datum ConwayEra -> Identity (Datum ConwayEra))
 -> TxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> Datum ConwayEra -> TxOut ConwayEra -> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Data -> Datum ConwayEra
mkInlineDatum
                        (CageDatum -> Data
forall a. ToData a => a -> Data
toPlcData CageDatum
newStateDatum)
        script :: Script ConwayEra
script = CageConfig -> Script ConwayEra
mkCageScript CageConfig
cfg
    in  (OnChainTokenState
oldState, TxOut ConwayEra
BabbageTxOut ConwayEra
newStateOut, AlonzoScript ConwayEra
Script ConwayEra
script)

-- | Compute the validity upper slot.
computeUpperSlot
    :: Session NoWitness IO
    -> OnChainTokenState
    -> [(TxIn, TxOut ConwayEra)]
    -> IO SlotNo
computeUpperSlot :: Session NoWitness IO
-> OnChainTokenState -> [(TxIn, TxOut ConwayEra)] -> IO SlotNo
computeUpperSlot Session NoWitness IO
view OnChainTokenState
oldState [(TxIn, TxOut ConwayEra)]
reqUtxos = do
    let extractSubmittedAt :: (a, BabbageTxOut ConwayEra) -> Integer
extractSubmittedAt (a
_, BabbageTxOut ConwayEra
rOut) =
            case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
BabbageTxOut ConwayEra
rOut of
                Just (RequestDatum OnChainRequest
r) ->
                    OnChainRequest -> Integer
requestSubmittedAt OnChainRequest
r
                Maybe CageDatum
_ -> Integer
0
        earliestDeadline :: Integer
earliestDeadline =
            [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$
                ((TxIn, BabbageTxOut ConwayEra) -> Integer)
-> [(TxIn, BabbageTxOut ConwayEra)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map
                    ( \(TxIn, BabbageTxOut ConwayEra)
u ->
                        (TxIn, BabbageTxOut ConwayEra) -> Integer
forall {a}. (a, BabbageTxOut ConwayEra) -> Integer
extractSubmittedAt (TxIn, BabbageTxOut ConwayEra)
u
                            Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ OnChainTokenState -> Integer
stateProcessTime
                                OnChainTokenState
oldState
                    )
                    [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
reqUtxos
    mUpperSlot <- IO SlotNo -> IO (Either SomeException SlotNo)
forall a. IO a -> IO (Either SomeException a)
trySync (Session NoWitness IO -> Integer -> IO SlotNo
forall w. Session w IO -> Integer -> IO SlotNo
Services.floorSlot Session NoWitness IO
view Integer
earliestDeadline)
    candidate <- case mUpperSlot of
        Right SlotNo
s -> SlotNo -> IO SlotNo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlotNo
s
        Left SomeException
_ -> do
            nowUtc <- IO UTCTime
getCurrentTime
            let posixSec =
                    UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
nowUtc
            tryUpperSlots view $
                map
                    ( \POSIXTime
d ->
                        POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round
                            ((POSIXTime
posixSec POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
d) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000)
                    )
                    [30, 5, 2]
    observed <- Services.tip view
    Services.validityUpper
        view
        (observedSlot observed)
        Nothing
        candidate

-- | Process a single request.
processRequest
    :: (Monad m)
    => Trie m
    -> (TxIn, TxOut ConwayEra)
    -> m [ProofStep]
processRequest :: forall (m :: * -> *).
Monad m =>
Trie m -> (TxIn, TxOut ConwayEra) -> m [ProofStep]
processRequest Trie m
trie (TxIn
_txIn, TxOut ConwayEra
txOut) =
    Trie m -> ByteString -> Integer -> m [ProofStep]
forall (m :: * -> *).
Monad m =>
Trie m -> ByteString -> Integer -> m [ProofStep]
walkEdge Trie m
trie (OnChainRequest -> ByteString
requestKey OnChainRequest
req) (OnChainRequest -> Integer
requestEdge OnChainRequest
req)
  where
    req :: OnChainRequest
req = case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
txOut of
        Just (RequestDatum OnChainRequest
r) -> OnChainRequest
r
        Maybe CageDatum
_ ->
            String -> OnChainRequest
forall a. HasCallStack => String -> a
error
                String
"processRequest: \
                \invalid request datum"

{- | Can this output fund a fold? It must hold ada and nothing else,
because it doubles as collateral, and it must not be one of the published
reference outputs, because a transaction may not both spend an output and
reference it.
-}
adaOnlyOutput :: TxOut ConwayEra -> Bool
adaOnlyOutput :: TxOut ConwayEra -> Bool
adaOnlyOutput TxOut ConwayEra
out =
    (case TxOut ConwayEra
BabbageTxOut ConwayEra
out 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 of MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
m) -> Map PolicyID (Map AssetName Integer) -> Bool
forall k a. Map k a -> Bool
Map.null Map PolicyID (Map AssetName Integer)
m)
        Bool -> Bool -> Bool
&& ( case TxOut ConwayEra
BabbageTxOut ConwayEra
out BabbageTxOut ConwayEra
-> Getting
     (StrictMaybe (Script ConwayEra))
     (BabbageTxOut ConwayEra)
     (StrictMaybe (Script ConwayEra))
-> StrictMaybe (Script ConwayEra)
forall s a. s -> Getting a s a -> a
^. (StrictMaybe (Script ConwayEra)
 -> Const
      (StrictMaybe (Script ConwayEra)) (StrictMaybe (Script ConwayEra)))
-> TxOut ConwayEra
-> Const (StrictMaybe (Script ConwayEra)) (TxOut ConwayEra)
Getting
  (StrictMaybe (Script ConwayEra))
  (BabbageTxOut ConwayEra)
  (StrictMaybe (Script ConwayEra))
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut ConwayEra) (StrictMaybe (Script ConwayEra))
referenceScriptTxOutL of
                StrictMaybe (Script ConwayEra)
SNothing -> Bool
True
                SJust Script ConwayEra
_ -> Bool
False
           )