{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

{- |
Module      : Singular.Registry.Driver
Description : Booting a registry and folding its edges, obligations discharged
License     : Apache-2.0

A fold's speculative session starts from the manager's COMMITTED trie and
is discarded ('updateTokenWithDuties'). So a caller that lands a fold and
does not mirror the edge into its manager builds the next proof against a
root the chain no longer has. The library stays correct throughout; the
caller is silently wrong, and the failure surfaces at the NEXT fold, which
looks like a defect somewhere else entirely. That cost three devnet runs
and an escalation on #173.

The obligation lived in a comment, so each new caller could forget it.
This module is where it lives now.

A caller cannot reach a fold except through a 'Registry', and the only way
to obtain one is 'bootRegistry'. 'foldEdge' books the edge, builds the
fold, submits it, mirrors it, and proves on both sides that the manager
and the chain agree:

  * BEFORE building, the manager's root must equal the chain's. A caller
    that landed a fold behind this driver's back is rejected HERE, naming
    both roots, rather than at some later unrelated fold.
  * AFTER mirroring, the two must agree again, and the root must have
    moved. A root that does not move across a landed fold is the #173
    defect, and it would otherwise be invisible.

What this module does NOT do is assert anything about the edge's meaning.
Booting, folding and keeping the mirror in step are its whole subject;
every caller keeps its own assertions and its own output.
-}
module Singular.Registry.Driver
    ( -- * The registry handle
      Registry
    , registryConfig
    , registryTokenId
    , registryRefs
    , registryBootTx

      -- * Booting
    , bootRegistry

      -- * Folding one edge
    , foldEdge
    , foldEdgeTo
    , FoldOutcome (..)

      -- * Reading the two roots
    , chainRoot
    , mirrorRoot
    , renderRoot

      -- * Deriving the token a boot minted
    , tokenIdOfBootTx
    ) where

import Control.Monad (unless, void, when)
import Data.ByteString (ByteString)
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as BSL
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Lens.Micro ((^.))
import PlutusCore.Data qualified as PLC

import Cardano.Ledger.Api.Tx (bodyTxL, witsTxL)
import Cardano.Ledger.Api.Tx.Body
    ( collateralInputsTxBodyL
    , feeTxBodyL
    , mintTxBodyL
    , referenceInputsTxBodyL
    )
import Cardano.Ledger.Api.Tx.Out (coinTxOutL)
import Cardano.Ledger.Api.Tx.Wits (scriptTxWitsL)
import Cardano.Ledger.Binary (serialize)
import Cardano.Ledger.Core (eraProtVerHigh)
import Cardano.Ledger.Mary.Value (MultiAsset (..))
import Cardano.Tx.Ledger (ConwayTx)

import Singular.Registry.Blueprint.Load (NamingCodes)
import Singular.Registry.Config (CageConfig (..))
import Singular.Registry.Evidence qualified as Cage
import Singular.Registry.Ledger
    ( Addr
    , AssetName (..)
    , Coin (..)
    , ConwayEra
    , Root (..)
    , TokenId (..)
    , TxIn
    , TxOut
    )
import Singular.Registry.LedgerProvider qualified as Cage
import Singular.Registry.SessionIO qualified as Cage
import Singular.Registry.Trie (Trie (..), TrieManager (..))
import Singular.Registry.TxBuilder.Boot (bootTokenImpl)
import Singular.Registry.TxBuilder.Edges (SubmitSigned)
import Singular.Registry.TxBuilder.Edges qualified as Edges
import Singular.Registry.TxBuilder.Internal.Edges (walkEdge)
import Singular.Registry.TxBuilder.Internal.Identity
    ( cageAddrFromCfg
    , cagePolicyIdFromCfg
    , extractCageDatum
    )
import Singular.Registry.TxBuilder.Internal.Lookup (findStateUtxo)
import Singular.Registry.TxBuilder.Update (updateTokenWithDuties)
import Singular.Registry.Types
    ( CageDatum (..)
    , Edge
    , OnChainRoot (..)
    , OnChainTokenState (..)
    )

{- | A booted registry, with everything a fold of its edges needs. The
constructor is deliberately NOT exported: 'bootRegistry' is the only way
to obtain one, so there is no state in which a caller holds the means to
fold and has not been through the boot that publishes the references and
creates the trie.
-}
data Registry = Registry
    { Registry -> CageConfig
regCfg :: CageConfig
    , Registry -> NamingCodes
regCodes :: NamingCodes
    , Registry -> (Network, LedgerProvider NoWitness IO)
regProv :: (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    , Registry -> SubmitSigned
regSubmit :: SubmitSigned
    , Registry -> Addr
regPayer :: Addr
    , Registry -> TrieManager IO
regTm :: TrieManager IO
    , Registry -> TokenId
regTid :: TokenId
    , Registry -> [(TxIn, TxOut ConwayEra)]
regRefs :: [(TxIn, TxOut ConwayEra)]
    , Registry -> ConwayTx
regBootTx :: ConwayTx
    }

-- | The configuration this registry was booted against.
registryConfig :: Registry -> CageConfig
registryConfig :: Registry -> CageConfig
registryConfig = Registry -> CageConfig
regCfg

-- | The token the boot minted.
registryTokenId :: Registry -> TokenId
registryTokenId :: Registry -> TokenId
registryTokenId = Registry -> TokenId
regTid

{- | The published reference outputs every fold resolves its scripts
through. A caller that books an edge itself needs them.
-}
registryRefs :: Registry -> [(TxIn, TxOut ConwayEra)]
registryRefs :: Registry -> [(TxIn, TxOut ConwayEra)]
registryRefs = Registry -> [(TxIn, TxOut ConwayEra)]
regRefs

-- | The signed boot transaction, for a caller that reports on it.
registryBootTx :: Registry -> ConwayTx
registryBootTx :: Registry -> ConwayTx
registryBootTx = Registry -> ConwayTx
regBootTx

{- | Boot a registry: mint its token, create its trie, and publish the
cage references every later fold resolves through.

The state validator alone is fifteen kilobytes against a sixteen-kilobyte
transaction cap, so the references are published once here rather than
attached per fold ('Edges.publishCageRefs'). The boot itself resolves
the state validator through a publication already in the payer's
wallet, and is refused `StateValidatorNotPublished` without one.
-}
bootRegistry
    :: CageConfig
    -> NamingCodes
    -> (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    -> SubmitSigned
    -> Addr
    -- ^ The payer, which is also where boot outputs land
    -> TrieManager IO
    -> IO Registry
bootRegistry :: CageConfig
-> NamingCodes
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> TrieManager IO
-> IO Registry
bootRegistry CageConfig
cfg NamingCodes
codes (Network, LedgerProvider NoWitness IO)
prov SubmitSigned
submit Addr
payer TrieManager IO
tm = do
    (bootWallet, unsignedBoot) <- (Network, LedgerProvider NoWitness IO)
-> (Session NoWitness IO
    -> IO ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx))
-> IO ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx)
forall w a.
(Network, LedgerProvider w IO) -> (Session w IO -> IO a) -> IO a
Cage.withLatest (Network, LedgerProvider NoWitness IO)
prov ((Session NoWitness IO
  -> IO ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx))
 -> IO ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx))
-> (Session NoWitness IO
    -> IO ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx))
-> IO ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx)
forall a b. (a -> b) -> a -> b
$ \Session NoWitness IO
v ->
        (,) ([(TxIn, BabbageTxOut ConwayEra)]
 -> ConwayTx -> ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx))
-> IO [(TxIn, BabbageTxOut ConwayEra)]
-> IO (ConwayTx -> ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session NoWitness IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
forall w. Session w IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
Cage.outputsAt Session NoWitness IO
v Addr
payer IO (ConwayTx -> ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx))
-> IO ConwayTx -> IO ([(TxIn, BabbageTxOut ConwayEra)], ConwayTx)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CageConfig -> Session NoWitness IO -> Addr -> IO ConwayTx
bootTokenImpl CageConfig
cfg Session NoWitness IO
v Addr
payer
    let bootScripts = ConwayTx
unsignedBoot ConwayTx
-> Getting
     (Map ScriptHash (Script ConwayEra))
     ConwayTx
     (Map ScriptHash (Script ConwayEra))
-> Map ScriptHash (Script ConwayEra)
forall s a. s -> Getting a s a -> a
^. (AlonzoTxWits ConwayEra
 -> Const
      (Map ScriptHash (Script ConwayEra)) (AlonzoTxWits ConwayEra))
-> ConwayTx -> Const (Map ScriptHash (Script ConwayEra)) ConwayTx
(TxWits ConwayEra
 -> Const (Map ScriptHash (Script ConwayEra)) (TxWits ConwayEra))
-> ConwayTx -> Const (Map ScriptHash (Script ConwayEra)) ConwayTx
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra
  -> Const
       (Map ScriptHash (Script ConwayEra)) (AlonzoTxWits ConwayEra))
 -> ConwayTx -> Const (Map ScriptHash (Script ConwayEra)) ConwayTx)
-> ((Map ScriptHash (Script ConwayEra)
     -> Const
          (Map ScriptHash (Script ConwayEra))
          (Map ScriptHash (Script ConwayEra)))
    -> AlonzoTxWits ConwayEra
    -> Const
         (Map ScriptHash (Script ConwayEra)) (AlonzoTxWits ConwayEra))
-> Getting
     (Map ScriptHash (Script ConwayEra))
     ConwayTx
     (Map ScriptHash (Script ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script ConwayEra)
 -> Const
      (Map ScriptHash (Script ConwayEra))
      (Map ScriptHash (Script ConwayEra)))
-> AlonzoTxWits ConwayEra
-> Const
     (Map ScriptHash (Script ConwayEra)) (AlonzoTxWits ConwayEra)
(Map ScriptHash (Script ConwayEra)
 -> Const
      (Map ScriptHash (Script ConwayEra))
      (Map ScriptHash (Script ConwayEra)))
-> TxWits ConwayEra
-> Const (Map ScriptHash (Script ConwayEra)) (TxWits ConwayEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits ConwayEra) (Map ScriptHash (Script ConwayEra))
scriptTxWitsL
        bootRefs = ConwayTx
unsignedBoot ConwayTx -> Getting (Set TxIn) ConwayTx (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> ConwayTx -> Const (Set TxIn) 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 (Set TxIn) (TxBody TopTx ConwayEra))
 -> ConwayTx -> Const (Set TxIn) ConwayTx)
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx ConwayEra
    -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Getting (Set TxIn) ConwayTx (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx ConwayEra
-> Const (Set TxIn) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
referenceInputsTxBodyL
        bootBytes =
            ByteString -> Int64
BSL.length (Version -> ConwayTx -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize (forall era. Era era => Version
eraProtVerHigh @ConwayEra) ConwayTx
unsignedBoot)
    -- The boot budget, printed rather than taken on trust: the state
    -- validator is fifteen kilobytes against a sixteen-kilobyte cap, so
    -- a reader of a run needs to see the room that is left.
    putStrLn
        ( "[boot] bytes="
            <> show bootBytes
            <> " inline-scripts="
            <> show (Map.size bootScripts)
            <> " reference-inputs="
            <> show (Set.size bootRefs)
            <> " fee="
            <> show (unsignedBoot ^. bodyTxL . feeTxBodyL)
            <> " collateral-coins="
            <> show
                [ c
                | i <- Set.toList (unsignedBoot ^. bodyTxL . collateralInputsTxBodyL)
                , (j, o) <- bootWallet
                , i == j
                , let Coin c = o ^. coinTxOutL
                ]
            <> " wallet-coins="
            <> show [c | (_, o) <- bootWallet, let Coin c = o ^. coinTxOutL]
        )
    signedBoot <- submit unsignedBoot
    tid <- tokenIdOfBootTx cfg signedBoot
    createTrie tm tid
    refs <- Edges.publishCageRefs cfg codes prov submit payer tid
    -- The boot is not booted until the chain holds its state UTxO.
    stateUtxos <-
        Cage.withLatest
            prov
            (`Cage.outputsAt` cageAddrFromCfg cfg (network cfg))
    when (null stateUtxos) $
        error "bootRegistry: the cage address holds no UTxO after the boot"
    pure
        Registry
            { regCfg = cfg
            , regCodes = codes
            , regProv = prov
            , regSubmit = submit
            , regPayer = payer
            , regTm = tm
            , regTid = tid
            , regRefs = refs
            , regBootTx = signedBoot
            }

{- | What one landed fold did, as the caller's receipt. The two roots are
the evidence that the mirror moved with the chain rather than behind it.
-}
data FoldOutcome = FoldOutcome
    { FoldOutcome -> ByteString
foKey :: ByteString
    , FoldOutcome -> Integer
foEdge :: Edge
    , FoldOutcome -> TxIn
foBooking :: TxIn
    -- ^ the request this fold consumed
    , FoldOutcome -> ConwayTx
foFoldTx :: ConwayTx
    -- ^ the signed fold, on chain
    , FoldOutcome -> Root
foRootBefore :: Root
    -- ^ the committed mirror root before the fold
    , FoldOutcome -> Root
foRootAfter :: Root
    -- ^ the committed mirror root after it, equal to the chain's
    }

{- | Book one edge, fold it, and commit it into the manager before any
later proof is built.

The order is not the caller's to get wrong, and the two root checks are
not the caller's to remember. See the module header for why both exist.
-}
foldEdge :: Registry -> ByteString -> Edge -> IO FoldOutcome
foldEdge :: Registry -> ByteString -> Integer -> IO FoldOutcome
foldEdge Registry
reg ByteString
key Integer
edge = Registry
-> ByteString
-> Integer
-> Maybe (ByteString, Maybe Data)
-> IO FoldOutcome
foldEdgeWith Registry
reg ByteString
key Integer
edge Maybe (ByteString, Maybe Data)
forall a. Maybe a
Nothing

{- | Fold one edge whose delivery goes to an explicitly named
destination rather than the one the edge would route to by itself.

The naming application routes an `insertActive` to its own script
address; a harness that has no spending arm there names a wallet
instead. That is the only difference, so it is a parameter here rather
than a second driver.
-}
foldEdgeTo
    :: Registry
    -> ByteString
    -> Edge
    -> (ByteString, Maybe PLC.Data)
    -- ^ destination address and the datum it carries, as `Edges.bookEdgeTo` takes them
    -> IO FoldOutcome
foldEdgeTo :: Registry
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> IO FoldOutcome
foldEdgeTo Registry
reg ByteString
key Integer
edge (ByteString, Maybe Data)
dest = Registry
-> ByteString
-> Integer
-> Maybe (ByteString, Maybe Data)
-> IO FoldOutcome
foldEdgeWith Registry
reg ByteString
key Integer
edge ((ByteString, Maybe Data) -> Maybe (ByteString, Maybe Data)
forall a. a -> Maybe a
Just (ByteString, Maybe Data)
dest)

foldEdgeWith
    :: Registry
    -> ByteString
    -> Edge
    -> Maybe (ByteString, Maybe PLC.Data)
    -> IO FoldOutcome
foldEdgeWith :: Registry
-> ByteString
-> Integer
-> Maybe (ByteString, Maybe Data)
-> IO FoldOutcome
foldEdgeWith Registry
reg ByteString
key Integer
edge Maybe (ByteString, Maybe Data)
mDest = do
    rootBefore <- Registry -> IO Root
mirrorRoot Registry
reg
    onChainBefore <- chainRoot reg
    -- The precondition nobody had. A caller that landed a fold behind
    -- this driver — built, submitted, and did not mirror — is rejected
    -- HERE, before a proof is built against a root the chain no longer
    -- has. Without it the omission is invisible until some later fold
    -- fails for a reason that has nothing to do with it.
    unless (unRoot rootBefore == unOnChainRoot onChainBefore) $
        error
            ( "foldEdge: the manager is out of step with the chain before \
              \folding "
                <> show key
                <> " (mirror "
                <> renderRoot (unRoot rootBefore)
                <> ", chain "
                <> renderRoot (unOnChainRoot onChainBefore)
                <> "): a fold landed without being committed into the \
                   \manager"
            )
    booking <- case mDest of
        Maybe (ByteString, Maybe Data)
Nothing ->
            CageConfig
-> NamingCodes
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> TokenId
-> ByteString
-> Integer
-> IO TxIn
Edges.bookEdge
                (Registry -> CageConfig
regCfg Registry
reg)
                (Registry -> NamingCodes
regCodes Registry
reg)
                (Registry -> (Network, LedgerProvider NoWitness IO)
regProv Registry
reg)
                (Registry -> SubmitSigned
regSubmit Registry
reg)
                (Registry -> Addr
regPayer Registry
reg)
                (Registry -> TokenId
regTid Registry
reg)
                ByteString
key
                Integer
edge
        Just (ByteString, Maybe Data)
dest ->
            CageConfig
-> NamingCodes
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> IO TxIn
Edges.bookEdgeTo
                (Registry -> CageConfig
regCfg Registry
reg)
                (Registry -> NamingCodes
regCodes Registry
reg)
                (Registry -> (Network, LedgerProvider NoWitness IO)
regProv Registry
reg)
                (Registry -> SubmitSigned
regSubmit Registry
reg)
                (Registry -> Addr
regPayer Registry
reg)
                (Registry -> TokenId
regTid Registry
reg)
                ByteString
key
                Integer
edge
                (ByteString, Maybe Data)
dest
    unsigned <- Cage.withLatest (regProv reg) $ \Session NoWitness IO
v -> do
        ctx <-
            CageConfig
-> NamingCodes
-> Session NoWitness IO
-> [(TxIn, TxOut ConwayEra)]
-> IO RegistryContext
Edges.registryContextFor
                (Registry -> CageConfig
regCfg Registry
reg)
                (Registry -> NamingCodes
regCodes Registry
reg)
                Session NoWitness IO
v
                (Registry -> [(TxIn, TxOut ConwayEra)]
regRefs Registry
reg)
        updateTokenWithDuties
            (regCfg reg)
            v
            (regTm reg)
            (regTid reg)
            (regPayer reg)
            ctx
    -- Building a fold is not folding it: the edge only lands once the
    -- transaction is on chain, and only then may the mirror move.
    signed <- regSubmit reg unsigned
    withTrie (regTm reg) (regTid reg) $ \Trie IO
t -> IO [ProofStep] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Trie IO -> ByteString -> Integer -> IO [ProofStep]
forall (m :: * -> *).
Monad m =>
Trie m -> ByteString -> Integer -> m [ProofStep]
walkEdge Trie IO
t ByteString
key Integer
edge)
    rootAfter <- mirrorRoot reg
    when (unRoot rootBefore == unRoot rootAfter) $
        error
            ( "foldEdge: the committed mirror root did not move across a \
              \landed fold of "
                <> show key
                <> " — the next fold would re-prove against a stale root"
            )
    onChain <- chainRoot reg
    unless (unRoot rootAfter == unOnChainRoot onChain) $
        error
            ( "foldEdge: after folding "
                <> show key
                <> " the mirror root and the chain root disagree (mirror "
                <> renderRoot (unRoot rootAfter)
                <> ", chain "
                <> renderRoot (unOnChainRoot onChain)
                <> ")"
            )
    pure
        FoldOutcome
            { foKey = key
            , foEdge = edge
            , foBooking = booking
            , foFoldTx = signed
            , foRootBefore = rootBefore
            , foRootAfter = rootAfter
            }

-- | The committed root the manager holds for this registry.
mirrorRoot :: Registry -> IO Root
mirrorRoot :: Registry -> IO Root
mirrorRoot Registry
reg = TrieManager IO -> forall a. TokenId -> (Trie IO -> IO a) -> IO a
forall (m :: * -> *).
TrieManager m -> forall a. TokenId -> (Trie m -> m a) -> m a
withTrie (Registry -> TrieManager IO
regTm Registry
reg) (Registry -> TokenId
regTid Registry
reg) Trie IO -> IO Root
forall (m :: * -> *). Trie m -> m Root
getRoot

{- | The root the chain holds, read off the state UTxO at the cage
address.
-}
chainRoot :: Registry -> IO OnChainRoot
chainRoot :: Registry -> IO OnChainRoot
chainRoot Registry
reg = do
    let cfg :: CageConfig
cfg = Registry -> CageConfig
regCfg Registry
reg
    utxos <-
        (Network, LedgerProvider NoWitness IO)
-> (Session NoWitness IO -> IO [(TxIn, TxOut ConwayEra)])
-> IO [(TxIn, TxOut ConwayEra)]
forall w a.
(Network, LedgerProvider w IO) -> (Session w IO -> IO a) -> IO a
Cage.withLatest
            (Registry -> (Network, LedgerProvider NoWitness IO)
regProv Registry
reg)
            (Session NoWitness IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
forall w. Session w IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
`Cage.outputsAt` CageConfig -> Network -> Addr
cageAddrFromCfg CageConfig
cfg (CageConfig -> Network
network CageConfig
cfg))
    case findStateUtxo (cagePolicyIdFromCfg cfg) (regTid reg) utxos of
        Maybe (TxIn, TxOut ConwayEra)
Nothing ->
            [Char] -> IO OnChainRoot
forall a. HasCallStack => [Char] -> a
error [Char]
"chainRoot: no state UTxO carrying the policy token"
        Just (TxIn
_, TxOut ConwayEra
out) -> case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
out of
            Just (StateDatum OnChainTokenState
s) -> OnChainRoot -> IO OnChainRoot
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnChainTokenState -> OnChainRoot
stateRoot OnChainTokenState
s)
            Maybe CageDatum
_ -> [Char] -> IO OnChainRoot
forall a. HasCallStack => [Char] -> a
error [Char]
"chainRoot: state UTxO datum is not a StateDatum"

{- | The token a boot transaction minted, read off its own mint field.
Six harnesses each carried a copy of this; it belongs here.
-}
tokenIdOfBootTx :: CageConfig -> ConwayTx -> IO TokenId
tokenIdOfBootTx :: CageConfig -> ConwayTx -> IO TokenId
tokenIdOfBootTx CageConfig
cfg ConwayTx
tx =
    let MultiAsset Map PolicyID (Map AssetName Integer)
ma = ConwayTx
tx ConwayTx -> Getting MultiAsset ConwayTx MultiAsset -> MultiAsset
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const MultiAsset (TxBody TopTx ConwayEra))
-> ConwayTx -> Const MultiAsset 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 MultiAsset (TxBody TopTx ConwayEra))
 -> ConwayTx -> Const MultiAsset ConwayTx)
-> ((MultiAsset -> Const MultiAsset MultiAsset)
    -> TxBody TopTx ConwayEra
    -> Const MultiAsset (TxBody TopTx ConwayEra))
-> Getting MultiAsset ConwayTx MultiAsset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiAsset -> Const MultiAsset MultiAsset)
-> TxBody TopTx ConwayEra
-> Const MultiAsset (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) MultiAsset
mintTxBodyL
    in  case Map AssetName Integer -> [(AssetName, Integer)]
forall k a. Map k a -> [(k, a)]
Map.toList
            (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 (CageConfig -> PolicyID
cagePolicyIdFromCfg CageConfig
cfg) Map PolicyID (Map AssetName Integer)
ma) of
            [(AssetName ShortByteString
an, Integer
_)] -> TokenId -> IO TokenId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AssetName -> TokenId
TokenId (ShortByteString -> AssetName
AssetName ShortByteString
an))
            [(AssetName, Integer)]
assets ->
                [Char] -> IO TokenId
forall a. HasCallStack => [Char] -> a
error
                    ( [Char]
"tokenIdOfBootTx: the boot minted "
                        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([(AssetName, Integer)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(AssetName, Integer)]
assets)
                        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" assets under the cage policy, not one"
                    )

{- | A root as the driver's diagnostics render it: lowercase hex, no
quoting. A caller that wants to assert on a rejection's text builds the
same string from a root it read itself, so the assertion binds the
values rather than the phrasing.
-}
renderRoot :: ByteString -> String
renderRoot :: ByteString -> [Char]
renderRoot = ByteString -> [Char]
BS8.unpack (ByteString -> [Char])
-> (ByteString -> ByteString) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode