{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}

{- |
Module      : Singular.Registry.StateToken
Description : A registry joined from its state token and the release
License     : Apache-2.0

A registry is its state token and the release that made it. Everything a
command needs — the seed, the state output and its datum, the pinned
configuration, and the hashes of the six scripts the registry runs — is
derived from those two and checked against the chain, refused by name
when the chain disagrees with the release. Nothing is read from disk.

Reference outputs are a convenience found by hash: any live output whose
reference script hashes to an expected hash serves, whoever made it. The
hash is computed here from the output's own script; a hash a provider
states is never read.
-}
module Singular.Registry.StateToken
    ( -- * The release
      Release (..)

      -- * The state token
    , parseStateToken
    , renderStateToken

      -- * Reference roles and the hashes they must carry
    , ReferenceRole (..)
    , roleName
    , parseRole
    , expectedReferences

      -- * Resolving a token into a registry
    , ResolvedRegistry (..)
    , PinField (..)
    , IdentityRefusal (..)
    , resolveRegistry
    , findStateOutput
    , renderIdentityRefusal

      -- * References found by hash
    , ReferenceRefusal (..)
    , carriesReference
    , findReferences
    , renderReferenceRefusal
    ) where

import Control.Monad (forM_, when)
import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Short qualified as SBS
import Data.List (minimumBy)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Ord (comparing)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Lens.Micro ((^.))
import PlutusTx.Builtins.Internal (BuiltinByteString (..))

import Cardano.Crypto.Hash.Class (hashFromBytes)
import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Api.Tx.Out
    ( TxOut
    , addrTxOutL
    , referenceScriptTxOutL
    , valueTxOutL
    )
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core (hashScript)
import Cardano.Ledger.Credential
    ( Credential (ScriptHashObj)
    , StakeReference (StakeRefNull)
    )
import Cardano.Ledger.Hashes (ScriptHash (..))
import Cardano.Ledger.Mary.Value
    ( AssetName (..)
    , MaryValue (..)
    , MultiAsset (..)
    , PolicyID (..)
    )
import Cardano.Ledger.TxIn (TxId, TxIn (..))

import Singular.Registry.Application
    ( Application (..)
    , ApplicationPin (..)
    , applyPin
    )
import Singular.Registry.AssetName (deriveAssetName)
import Singular.Registry.Blueprint (NamingCodes, applyRequestParams)
import Singular.Registry.Config (CageConfig (..))
import Singular.Registry.Config.Application
    ( RegistryEconomics (..)
    , configForApplication
    )
import Singular.Registry.Deployment.Manifest (renderOutRef)
import Singular.Registry.Evidence (Evidenced (..))
import Singular.Registry.Ledger (ConwayEra)
import Singular.Registry.LedgerProvider
    ( Asset
    , MintRecord (..)
    , Network (..)
    , OutputQuery (..)
    , ReadFailure (..)
    , Session (..)
    )
import Singular.Registry.TxBuilder.Edges (namingPins)
import Singular.Registry.TxBuilder.Internal
    ( computeScriptHash
    , extractCageDatum
    , scriptHashBytes
    , txInToRef
    )
import Singular.Registry.Types
    ( CageDatum (..)
    , OnChainTokenId (..)
    , OnChainTokenState (..)
    , stateAbsentPolicyBytes
    , stateActivePolicyBytes
    , stateAppPolicyBytes
    , stateTerminalPolicyBytes
    )

-- | The compiled code a registry command needs from the blueprint.
data Release = Release
    { Release -> ShortByteString
releaseState :: SBS.ShortByteString
    , Release -> ShortByteString
releaseRequest :: SBS.ShortByteString
    , Release -> NamingCodes
releaseCodes :: NamingCodes
    {- ^ The application's validator unapplied and @witness.witness@, from the
    same blueprint
    -}
    }

{- | A state token as the command line spells it, @POLICY.NAME@, each part
in hex: a 28-byte policy and a 32-byte name. Any other shape is refused
before any provider is asked.
-}
parseStateToken :: Text -> Either Text Asset
parseStateToken :: Text -> Either Text Asset
parseStateToken Text
spelling = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
spelling of
    [Text
policyHex, Text
nameHex] -> do
        policy <- Int -> Text -> Text -> Either Text ByteString
sized Int
28 Text
"policy" Text
policyHex
        name <- sized 32 "name" nameHex
        hash <-
            maybe
                (Left "the policy is not a script hash")
                Right
                (hashFromBytes policy)
        Right (PolicyID (ScriptHash hash), AssetName (SBS.toShort name))
    [Text]
_ -> Text -> Either Text Asset
forall a b. a -> Either a b
Left Text
"a state token is POLICY.NAME, each part in hex"
  where
    sized :: Int -> Text -> Text -> Either Text ByteString
sized Int
n Text
what Text
text = case ByteString -> Either String ByteString
B16.decode (Text -> ByteString
TE.encodeUtf8 Text
text) of
        Right ByteString
bytes
            | ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n -> ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
bytes
            | Bool
otherwise ->
                Text -> Either Text ByteString
forall a b. a -> Either a b
Left
                    ( Text
"the "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bytes))
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes, not "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)
                    )
        Left String
_ -> Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text
"the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not hex")

-- | The @POLICY.NAME@ spelling of a state token.
renderStateToken :: Asset -> Text
renderStateToken :: Asset -> Text
renderStateToken (PolicyID ScriptHash
policy, AssetName ShortByteString
name) =
    ByteString -> Text
hexText (ScriptHash -> ByteString
scriptHashBytes ScriptHash
policy)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
hexText (ShortByteString -> ByteString
SBS.fromShort ShortByteString
name)

-- | The six scripts a registry runs, by the role their reference plays.
data ReferenceRole
    = RoleState
    | RoleRequest
    | RoleWitnessAbsent
    | RoleWitnessActive
    | RoleWitnessTerminal
    | RoleApplication
    deriving stock (ReferenceRole -> ReferenceRole -> Bool
(ReferenceRole -> ReferenceRole -> Bool)
-> (ReferenceRole -> ReferenceRole -> Bool) -> Eq ReferenceRole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReferenceRole -> ReferenceRole -> Bool
== :: ReferenceRole -> ReferenceRole -> Bool
$c/= :: ReferenceRole -> ReferenceRole -> Bool
/= :: ReferenceRole -> ReferenceRole -> Bool
Eq, Eq ReferenceRole
Eq ReferenceRole =>
(ReferenceRole -> ReferenceRole -> Ordering)
-> (ReferenceRole -> ReferenceRole -> Bool)
-> (ReferenceRole -> ReferenceRole -> Bool)
-> (ReferenceRole -> ReferenceRole -> Bool)
-> (ReferenceRole -> ReferenceRole -> Bool)
-> (ReferenceRole -> ReferenceRole -> ReferenceRole)
-> (ReferenceRole -> ReferenceRole -> ReferenceRole)
-> Ord ReferenceRole
ReferenceRole -> ReferenceRole -> Bool
ReferenceRole -> ReferenceRole -> Ordering
ReferenceRole -> ReferenceRole -> ReferenceRole
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ReferenceRole -> ReferenceRole -> Ordering
compare :: ReferenceRole -> ReferenceRole -> Ordering
$c< :: ReferenceRole -> ReferenceRole -> Bool
< :: ReferenceRole -> ReferenceRole -> Bool
$c<= :: ReferenceRole -> ReferenceRole -> Bool
<= :: ReferenceRole -> ReferenceRole -> Bool
$c> :: ReferenceRole -> ReferenceRole -> Bool
> :: ReferenceRole -> ReferenceRole -> Bool
$c>= :: ReferenceRole -> ReferenceRole -> Bool
>= :: ReferenceRole -> ReferenceRole -> Bool
$cmax :: ReferenceRole -> ReferenceRole -> ReferenceRole
max :: ReferenceRole -> ReferenceRole -> ReferenceRole
$cmin :: ReferenceRole -> ReferenceRole -> ReferenceRole
min :: ReferenceRole -> ReferenceRole -> ReferenceRole
Ord, Int -> ReferenceRole -> ShowS
[ReferenceRole] -> ShowS
ReferenceRole -> String
(Int -> ReferenceRole -> ShowS)
-> (ReferenceRole -> String)
-> ([ReferenceRole] -> ShowS)
-> Show ReferenceRole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReferenceRole -> ShowS
showsPrec :: Int -> ReferenceRole -> ShowS
$cshow :: ReferenceRole -> String
show :: ReferenceRole -> String
$cshowList :: [ReferenceRole] -> ShowS
showList :: [ReferenceRole] -> ShowS
Show, Int -> ReferenceRole
ReferenceRole -> Int
ReferenceRole -> [ReferenceRole]
ReferenceRole -> ReferenceRole
ReferenceRole -> ReferenceRole -> [ReferenceRole]
ReferenceRole -> ReferenceRole -> ReferenceRole -> [ReferenceRole]
(ReferenceRole -> ReferenceRole)
-> (ReferenceRole -> ReferenceRole)
-> (Int -> ReferenceRole)
-> (ReferenceRole -> Int)
-> (ReferenceRole -> [ReferenceRole])
-> (ReferenceRole -> ReferenceRole -> [ReferenceRole])
-> (ReferenceRole -> ReferenceRole -> [ReferenceRole])
-> (ReferenceRole
    -> ReferenceRole -> ReferenceRole -> [ReferenceRole])
-> Enum ReferenceRole
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ReferenceRole -> ReferenceRole
succ :: ReferenceRole -> ReferenceRole
$cpred :: ReferenceRole -> ReferenceRole
pred :: ReferenceRole -> ReferenceRole
$ctoEnum :: Int -> ReferenceRole
toEnum :: Int -> ReferenceRole
$cfromEnum :: ReferenceRole -> Int
fromEnum :: ReferenceRole -> Int
$cenumFrom :: ReferenceRole -> [ReferenceRole]
enumFrom :: ReferenceRole -> [ReferenceRole]
$cenumFromThen :: ReferenceRole -> ReferenceRole -> [ReferenceRole]
enumFromThen :: ReferenceRole -> ReferenceRole -> [ReferenceRole]
$cenumFromTo :: ReferenceRole -> ReferenceRole -> [ReferenceRole]
enumFromTo :: ReferenceRole -> ReferenceRole -> [ReferenceRole]
$cenumFromThenTo :: ReferenceRole -> ReferenceRole -> ReferenceRole -> [ReferenceRole]
enumFromThenTo :: ReferenceRole -> ReferenceRole -> ReferenceRole -> [ReferenceRole]
Enum, ReferenceRole
ReferenceRole -> ReferenceRole -> Bounded ReferenceRole
forall a. a -> a -> Bounded a
$cminBound :: ReferenceRole
minBound :: ReferenceRole
$cmaxBound :: ReferenceRole
maxBound :: ReferenceRole
Bounded)

-- | A role as receipts spell it.
roleName :: ReferenceRole -> Text
roleName :: ReferenceRole -> Text
roleName = \case
    ReferenceRole
RoleState -> Text
"state"
    ReferenceRole
RoleRequest -> Text
"request"
    ReferenceRole
RoleWitnessAbsent -> Text
"witness-absent"
    ReferenceRole
RoleWitnessActive -> Text
"witness-active"
    ReferenceRole
RoleWitnessTerminal -> Text
"witness-terminal"
    ReferenceRole
RoleApplication -> Text
"application"

-- | A role from its receipt spelling.
parseRole :: Text -> Maybe ReferenceRole
parseRole :: Text -> Maybe ReferenceRole
parseRole Text
name = Text -> [(Text, ReferenceRole)] -> Maybe ReferenceRole
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name [(ReferenceRole -> Text
roleName ReferenceRole
r, ReferenceRole
r) | ReferenceRole
r <- [ReferenceRole
forall a. Bounded a => a
minBound .. ReferenceRole
forall a. Bounded a => a
maxBound]]

{- | The script hash each role must carry, derived from the release, the
application pin and the token alone. The state hash is the release's
state script; every other role is the release's script for it applied to
the registry identity, state policy then token name. A pin read from
state arrives as 'PinByHash' of the datum's pin: 'resolveRegistry'
reads the datum first. A hash pin publishes no application reference
(slice 2: its script bytes do not exist), so it omits that role; a script
or compiled pin lists it as today.
-}
expectedReferences
    :: ApplicationPin -> Release -> Asset -> Map ReferenceRole ScriptHash
expectedReferences :: ApplicationPin -> Release -> Asset -> Map ReferenceRole ScriptHash
expectedReferences ApplicationPin
pinForm Release
release (PolicyID
_, AssetName ShortByteString
name) =
    [(ReferenceRole, ScriptHash)] -> Map ReferenceRole ScriptHash
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        ( [ (ReferenceRole
RoleState, ScriptHash
stateHash)
          , (ReferenceRole
RoleRequest, ShortByteString -> ScriptHash
computeScriptHash ShortByteString
requestBytes)
          , (ReferenceRole
RoleWitnessAbsent, ShortByteString -> ScriptHash
pinHash ShortByteString
absentPin)
          , (ReferenceRole
RoleWitnessActive, ShortByteString -> ScriptHash
pinHash ShortByteString
activePin)
          , (ReferenceRole
RoleWitnessTerminal, ShortByteString -> ScriptHash
pinHash ShortByteString
terminalPin)
          ]
            [(ReferenceRole, ScriptHash)]
-> [(ReferenceRole, ScriptHash)] -> [(ReferenceRole, ScriptHash)]
forall a. Semigroup a => a -> a -> a
<> [(ReferenceRole
RoleApplication, ShortByteString -> ScriptHash
pinHash ShortByteString
applicationPin) | Bool
hasApplication]
        )
  where
    stateHash :: ScriptHash
stateHash = ShortByteString -> ScriptHash
computeScriptHash (Release -> ShortByteString
releaseState Release
release)
    registryId :: ByteString
registryId = ScriptHash -> ByteString
scriptHashBytes ScriptHash
stateHash ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> ByteString
SBS.fromShort ShortByteString
name
    (ShortByteString
applicationPin, NamingCodes
pinned) = ApplicationPin
-> ByteString -> NamingCodes -> (ShortByteString, NamingCodes)
applyPin ApplicationPin
pinForm ByteString
registryId (Release -> NamingCodes
releaseCodes Release
release)
    (ShortByteString
_, ShortByteString
absentPin, ShortByteString
activePin, ShortByteString
terminalPin) =
        NamingCodes
-> ByteString
-> (ShortByteString, ShortByteString, ShortByteString,
    ShortByteString)
namingPins NamingCodes
pinned ByteString
registryId
    -- A hash pin (including a pin read from state, which arrives as one)
    -- publishes no application reference; a script or compiled pin does.
    hasApplication :: Bool
hasApplication = case ApplicationPin
pinForm of
        PinByHash ShortByteString
_ -> Bool
False
        ApplicationPin
PinFromState -> Bool
False
        PinByScript Text
_ -> Bool
True
        PinAsCompiled Text
_ -> Bool
True
    requestBytes :: ShortByteString
requestBytes =
        ByteString -> OnChainTokenId -> ShortByteString -> ShortByteString
applyRequestParams
            (ScriptHash -> ByteString
scriptHashBytes ScriptHash
stateHash)
            (BuiltinByteString -> OnChainTokenId
OnChainTokenId (ByteString -> BuiltinByteString
BuiltinByteString (ShortByteString -> ByteString
SBS.fromShort ShortByteString
name)))
            (Release -> ShortByteString
releaseRequest Release
release)
    pinHash :: ShortByteString -> ScriptHash
pinHash ShortByteString
pin =
        ScriptHash
-> (Hash ADDRHASH EraIndependentScript -> ScriptHash)
-> Maybe (Hash ADDRHASH EraIndependentScript)
-> ScriptHash
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (String -> ScriptHash
forall a. HasCallStack => String -> a
error String
"expectedReferences: a pin is not a script hash")
            Hash ADDRHASH EraIndependentScript -> ScriptHash
ScriptHash
            (ByteString -> Maybe (Hash ADDRHASH EraIndependentScript)
forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
hashFromBytes (ShortByteString -> ByteString
SBS.fromShort ShortByteString
pin))

-- | The datum policy a registry pins, in the order they are compared.
data PinField
    = PinApplication
    | PinActive
    | PinAbsent
    | PinTerminal
    deriving stock (PinField -> PinField -> Bool
(PinField -> PinField -> Bool)
-> (PinField -> PinField -> Bool) -> Eq PinField
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PinField -> PinField -> Bool
== :: PinField -> PinField -> Bool
$c/= :: PinField -> PinField -> Bool
/= :: PinField -> PinField -> Bool
Eq, Eq PinField
Eq PinField =>
(PinField -> PinField -> Ordering)
-> (PinField -> PinField -> Bool)
-> (PinField -> PinField -> Bool)
-> (PinField -> PinField -> Bool)
-> (PinField -> PinField -> Bool)
-> (PinField -> PinField -> PinField)
-> (PinField -> PinField -> PinField)
-> Ord PinField
PinField -> PinField -> Bool
PinField -> PinField -> Ordering
PinField -> PinField -> PinField
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PinField -> PinField -> Ordering
compare :: PinField -> PinField -> Ordering
$c< :: PinField -> PinField -> Bool
< :: PinField -> PinField -> Bool
$c<= :: PinField -> PinField -> Bool
<= :: PinField -> PinField -> Bool
$c> :: PinField -> PinField -> Bool
> :: PinField -> PinField -> Bool
$c>= :: PinField -> PinField -> Bool
>= :: PinField -> PinField -> Bool
$cmax :: PinField -> PinField -> PinField
max :: PinField -> PinField -> PinField
$cmin :: PinField -> PinField -> PinField
min :: PinField -> PinField -> PinField
Ord, Int -> PinField -> ShowS
[PinField] -> ShowS
PinField -> String
(Int -> PinField -> ShowS)
-> (PinField -> String) -> ([PinField] -> ShowS) -> Show PinField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PinField -> ShowS
showsPrec :: Int -> PinField -> ShowS
$cshow :: PinField -> String
show :: PinField -> String
$cshowList :: [PinField] -> ShowS
showList :: [PinField] -> ShowS
Show, Int -> PinField
PinField -> Int
PinField -> [PinField]
PinField -> PinField
PinField -> PinField -> [PinField]
PinField -> PinField -> PinField -> [PinField]
(PinField -> PinField)
-> (PinField -> PinField)
-> (Int -> PinField)
-> (PinField -> Int)
-> (PinField -> [PinField])
-> (PinField -> PinField -> [PinField])
-> (PinField -> PinField -> [PinField])
-> (PinField -> PinField -> PinField -> [PinField])
-> Enum PinField
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: PinField -> PinField
succ :: PinField -> PinField
$cpred :: PinField -> PinField
pred :: PinField -> PinField
$ctoEnum :: Int -> PinField
toEnum :: Int -> PinField
$cfromEnum :: PinField -> Int
fromEnum :: PinField -> Int
$cenumFrom :: PinField -> [PinField]
enumFrom :: PinField -> [PinField]
$cenumFromThen :: PinField -> PinField -> [PinField]
enumFromThen :: PinField -> PinField -> [PinField]
$cenumFromTo :: PinField -> PinField -> [PinField]
enumFromTo :: PinField -> PinField -> [PinField]
$cenumFromThenTo :: PinField -> PinField -> PinField -> [PinField]
enumFromThenTo :: PinField -> PinField -> PinField -> [PinField]
Enum, PinField
PinField -> PinField -> Bounded PinField
forall a. a -> a -> Bounded a
$cminBound :: PinField
minBound :: PinField
$cmaxBound :: PinField
maxBound :: PinField
Bounded)

-- | A registry exists only once every identity check has passed.
data ResolvedRegistry = ResolvedRegistry
    { ResolvedRegistry -> Asset
resolvedToken :: Asset
    , ResolvedRegistry -> TxIn
resolvedSeed :: TxIn
    -- ^ The minting transaction's input whose derived name is the token's
    , ResolvedRegistry -> TxId
resolvedCreation :: TxId
    -- ^ The minting transaction
    , ResolvedRegistry -> (TxIn, TxOut ConwayEra)
resolvedState :: (TxIn, TxOut ConwayEra)
    -- ^ The output holding the token at the state address
    , ResolvedRegistry -> OnChainTokenState
resolvedDatum :: OnChainTokenState
    -- ^ Its state datum: root, windows, tip and the four pins
    , ResolvedRegistry -> CageConfig
resolvedConfig :: CageConfig
    {- ^ The configuration derived from the release and the token, with the
    windows and tip read from the datum
    -}
    , ResolvedRegistry -> NamingCodes
resolvedCodes :: NamingCodes
    -- ^ The application and witness codes as this registry runs them
    , ResolvedRegistry -> Map ReferenceRole ScriptHash
resolvedExpected :: Map ReferenceRole ScriptHash
    , ResolvedRegistry -> Network
resolvedNetwork :: Network
    -- ^ The provider session's network
    }

-- | Why a state token is not a registry of this release, in checking order.
data IdentityRefusal
    = -- | The token's policy is not this release's state script
      StateTokenForeignRelease ScriptHash
    | -- | The provider has no record of the asset
      StateTokenNotFound
    | -- | The supply is not one: the supply found
      StateTokenBurned Integer
    | -- | The minting transaction spends no seed of the token's name
      StateTokenSeedMismatch TxId
    | -- | No output holds the token at the state address with a state datum
      StateOutputMissing
    | -- | A datum pin differs from the hash the release and token derive
      RegistryPinMismatch PinField
    | -- | The provider's network is not the release's
      NetworkMismatch Network
    | -- | The provider could not be read; no identity fact was decided
      IdentityUnreadable ReadFailure
    deriving stock (IdentityRefusal -> IdentityRefusal -> Bool
(IdentityRefusal -> IdentityRefusal -> Bool)
-> (IdentityRefusal -> IdentityRefusal -> Bool)
-> Eq IdentityRefusal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IdentityRefusal -> IdentityRefusal -> Bool
== :: IdentityRefusal -> IdentityRefusal -> Bool
$c/= :: IdentityRefusal -> IdentityRefusal -> Bool
/= :: IdentityRefusal -> IdentityRefusal -> Bool
Eq, Int -> IdentityRefusal -> ShowS
[IdentityRefusal] -> ShowS
IdentityRefusal -> String
(Int -> IdentityRefusal -> ShowS)
-> (IdentityRefusal -> String)
-> ([IdentityRefusal] -> ShowS)
-> Show IdentityRefusal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IdentityRefusal -> ShowS
showsPrec :: Int -> IdentityRefusal -> ShowS
$cshow :: IdentityRefusal -> String
show :: IdentityRefusal -> String
$cshowList :: [IdentityRefusal] -> ShowS
showList :: [IdentityRefusal] -> ShowS
Show)

{- | Resolve a state token into a registry, refusing by name in the checking
order. No file is read. The application pin is compared with the state
datum only for a script pin; a pin read from state is taken from the
datum, and the three witness pins are compared as always.
-}
resolveRegistry
    :: (Monad m)
    => Application
    -> Release
    -> Asset
    -> Session w m
    -> m (Either IdentityRefusal ResolvedRegistry)
resolveRegistry :: forall (m :: * -> *) w.
Monad m =>
Application
-> Release
-> Asset
-> Session w m
-> m (Either IdentityRefusal ResolvedRegistry)
resolveRegistry Application
app Release
release token :: Asset
token@(PolicyID ScriptHash
policy, AssetName ShortByteString
name) Session w m
session =
    ExceptT IdentityRefusal m ResolvedRegistry
-> m (Either IdentityRefusal ResolvedRegistry)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT IdentityRefusal m ResolvedRegistry
 -> m (Either IdentityRefusal ResolvedRegistry))
-> ExceptT IdentityRefusal m ResolvedRegistry
-> m (Either IdentityRefusal ResolvedRegistry)
forall a b. (a -> b) -> a -> b
$ do
        let stateHash :: ScriptHash
stateHash = ShortByteString -> ScriptHash
computeScriptHash (Release -> ShortByteString
releaseState Release
release)
        Bool
-> ExceptT IdentityRefusal m () -> ExceptT IdentityRefusal m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScriptHash
policy ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
/= ScriptHash
stateHash) (ExceptT IdentityRefusal m () -> ExceptT IdentityRefusal m ())
-> ExceptT IdentityRefusal m () -> ExceptT IdentityRefusal m ()
forall a b. (a -> b) -> a -> b
$
            IdentityRefusal -> ExceptT IdentityRefusal m ()
forall a. IdentityRefusal -> ExceptT IdentityRefusal m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ScriptHash -> IdentityRefusal
StateTokenForeignRelease ScriptHash
stateHash)
        record <-
            m (Either ReadFailure (Evidenced w (Maybe MintRecord)))
-> ExceptT IdentityRefusal m (Maybe MintRecord)
forall {m :: * -> *} {w} {a}.
Functor m =>
m (Either ReadFailure (Evidenced w a))
-> ExceptT IdentityRefusal m a
readFact (Session w m
-> Asset -> m (Either ReadFailure (Evidenced w (Maybe MintRecord)))
forall w (m :: * -> *).
Session w m
-> Asset -> m (Either ReadFailure (Evidenced w (Maybe MintRecord)))
mintRecord Session w m
session Asset
token)
                ExceptT IdentityRefusal m (Maybe MintRecord)
-> (Maybe MintRecord -> ExceptT IdentityRefusal m MintRecord)
-> ExceptT IdentityRefusal m MintRecord
forall a b.
ExceptT IdentityRefusal m a
-> (a -> ExceptT IdentityRefusal m b)
-> ExceptT IdentityRefusal m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExceptT IdentityRefusal m MintRecord
-> (MintRecord -> ExceptT IdentityRefusal m MintRecord)
-> Maybe MintRecord
-> ExceptT IdentityRefusal m MintRecord
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IdentityRefusal -> ExceptT IdentityRefusal m MintRecord
forall a. IdentityRefusal -> ExceptT IdentityRefusal m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError IdentityRefusal
StateTokenNotFound) MintRecord -> ExceptT IdentityRefusal m MintRecord
forall a. a -> ExceptT IdentityRefusal m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        when (mintSupply record /= 1) $
            throwError (StateTokenBurned (mintSupply record))
        seed <-
            case filter derivesName (mintSpentInputs record) of
                TxIn
found : [TxIn]
_ -> TxIn -> ExceptT IdentityRefusal m TxIn
forall a. a -> ExceptT IdentityRefusal m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxIn
found
                [] -> IdentityRefusal -> ExceptT IdentityRefusal m TxIn
forall a. IdentityRefusal -> ExceptT IdentityRefusal m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TxId -> IdentityRefusal
StateTokenSeedMismatch (MintRecord -> TxId
mintTransaction MintRecord
record))
        (stateRef, stateOut, datum) <- ExceptT (findStateOutput token session)
        effectivePin <- case appPin app of
            ApplicationPin
PinFromState ->
                ApplicationPin -> ExceptT IdentityRefusal m ApplicationPin
forall a. a -> ExceptT IdentityRefusal m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShortByteString -> ApplicationPin
PinByHash (ByteString -> ShortByteString
SBS.toShort (OnChainTokenState -> ByteString
stateAppPolicyBytes OnChainTokenState
datum)))
            ApplicationPin
pin -> ApplicationPin -> ExceptT IdentityRefusal m ApplicationPin
forall a. a -> ExceptT IdentityRefusal m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ApplicationPin
pin
        let (cfg, codes) =
                configForApplication
                    effectivePin
                    (releaseCodes release)
                    (releaseState release)
                    (releaseRequest release)
                    RegistryEconomics
                        { reProcessTime = stateProcessTime datum
                        , reRetractTime = stateRetractTime datum
                        , reTip = Coin (stateMaxFee datum)
                        }
                    Ledger.Testnet
                    (txInToRef seed)
        forM_ checkFields $ \PinField
field ->
            Bool
-> ExceptT IdentityRefusal m () -> ExceptT IdentityRefusal m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PinField -> OnChainTokenState -> ByteString
datumPin PinField
field OnChainTokenState
datum ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ShortByteString -> ByteString
SBS.fromShort (PinField -> CageConfig -> ShortByteString
configPin PinField
field CageConfig
cfg)) (ExceptT IdentityRefusal m () -> ExceptT IdentityRefusal m ())
-> ExceptT IdentityRefusal m () -> ExceptT IdentityRefusal m ()
forall a b. (a -> b) -> a -> b
$
                IdentityRefusal -> ExceptT IdentityRefusal m ()
forall a. IdentityRefusal -> ExceptT IdentityRefusal m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PinField -> IdentityRefusal
RegistryPinMismatch PinField
field)
        let network = Session w m -> Network
forall w (m :: * -> *). Session w m -> Network
sessionNetwork Session w m
session
        when (ledgerNetwork network /= Ledger.Testnet) $
            throwError (NetworkMismatch network)
        pure
            ResolvedRegistry
                { resolvedToken = token
                , resolvedSeed = seed
                , resolvedCreation = mintTransaction record
                , resolvedState = (stateRef, stateOut)
                , resolvedDatum = datum
                , resolvedConfig = cfg
                , resolvedCodes = codes
                , resolvedExpected = expectedReferences effectivePin release token
                , resolvedNetwork = network
                }
  where
    -- \| The datum pins this resolution compares: the three witness pins
    -- always, the application pin only for a script pin.
    checkFields :: [PinField]
checkFields = case Application -> ApplicationPin
appPin Application
app of
        PinByScript Text
_ -> [PinField
forall a. Bounded a => a
minBound .. PinField
forall a. Bounded a => a
maxBound]
        ApplicationPin
_ -> [PinField
PinActive, PinField
PinAbsent, PinField
PinTerminal]
    derivesName :: TxIn -> Bool
derivesName TxIn
input = OnChainTxOutRef -> ByteString
deriveAssetName (TxIn -> OnChainTxOutRef
txInToRef TxIn
input) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ShortByteString -> ByteString
SBS.fromShort ShortByteString
name
    readFact :: m (Either ReadFailure (Evidenced w a))
-> ExceptT IdentityRefusal m a
readFact m (Either ReadFailure (Evidenced w a))
action =
        m (Either IdentityRefusal a) -> ExceptT IdentityRefusal m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
            ((Either ReadFailure (Evidenced w a) -> Either IdentityRefusal a)
-> m (Either ReadFailure (Evidenced w a))
-> m (Either IdentityRefusal a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ReadFailure -> Either IdentityRefusal a)
-> (Evidenced w a -> Either IdentityRefusal a)
-> Either ReadFailure (Evidenced w a)
-> Either IdentityRefusal a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IdentityRefusal -> Either IdentityRefusal a
forall a b. a -> Either a b
Left (IdentityRefusal -> Either IdentityRefusal a)
-> (ReadFailure -> IdentityRefusal)
-> ReadFailure
-> Either IdentityRefusal a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadFailure -> IdentityRefusal
IdentityUnreadable) (a -> Either IdentityRefusal a
forall a b. b -> Either a b
Right (a -> Either IdentityRefusal a)
-> (Evidenced w a -> a)
-> Evidenced w a
-> Either IdentityRefusal a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Evidenced w a -> a
forall w a. Evidenced w a -> a
value)) m (Either ReadFailure (Evidenced w a))
action)

{- | The output that holds the token at the state address of the token's
policy, with its state datum. The provider's answer to who holds the token
is unverified: each listed output is admitted only if its own value holds
the token. A command reads the state again through this after it has
resolved the registry, since every transition moves the state output.
-}
findStateOutput
    :: (Monad m)
    => Asset
    -> Session w m
    -> m (Either IdentityRefusal (TxIn, TxOut ConwayEra, OnChainTokenState))
findStateOutput :: forall (m :: * -> *) w.
Monad m =>
Asset
-> Session w m
-> m (Either
        IdentityRefusal (TxIn, TxOut ConwayEra, OnChainTokenState))
findStateOutput token :: Asset
token@(PolicyID ScriptHash
policy, AssetName ShortByteString
name) Session w m
session = do
    answer <- Session w m
-> OutputQuery -> m (Either ReadFailure (Evidenced w Outputs))
forall w (m :: * -> *).
Session w m
-> OutputQuery -> m (Either ReadFailure (Evidenced w Outputs))
outputs Session w m
session (Asset -> OutputQuery
HoldingAsset Asset
token)
    pure $ case answer of
        Left ReadFailure
failure -> IdentityRefusal
-> Either
     IdentityRefusal (TxIn, BabbageTxOut ConwayEra, OnChainTokenState)
forall a b. a -> Either a b
Left (ReadFailure -> IdentityRefusal
IdentityUnreadable ReadFailure
failure)
        Right Evidenced w [(TxIn, BabbageTxOut ConwayEra)]
held ->
            case [ (TxIn
i, BabbageTxOut ConwayEra
o, OnChainTokenState
st)
                 | (TxIn
i, BabbageTxOut ConwayEra
o) <- Evidenced w [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall w a. Evidenced w a -> a
value Evidenced w [(TxIn, BabbageTxOut ConwayEra)]
held
                 , TxOut ConwayEra -> Bool
forall {era}.
(Value era ~ MaryValue,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
TxOut era -> Bool
holdsToken TxOut ConwayEra
BabbageTxOut ConwayEra
o
                 , BabbageTxOut ConwayEra
o BabbageTxOut ConwayEra
-> Getting Addr (BabbageTxOut ConwayEra) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. (Addr -> Const Addr Addr)
-> TxOut ConwayEra -> Const Addr (TxOut ConwayEra)
Getting Addr (BabbageTxOut ConwayEra) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut ConwayEra) Addr
addrTxOutL Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
stateAddress
                 , Just (StateDatum OnChainTokenState
st) <- [TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
BabbageTxOut ConwayEra
o]
                 ] of
                (TxIn, BabbageTxOut ConwayEra, OnChainTokenState)
found : [(TxIn, BabbageTxOut ConwayEra, OnChainTokenState)]
_ -> (TxIn, BabbageTxOut ConwayEra, OnChainTokenState)
-> Either
     IdentityRefusal (TxIn, BabbageTxOut ConwayEra, OnChainTokenState)
forall a b. b -> Either a b
Right (TxIn, BabbageTxOut ConwayEra, OnChainTokenState)
found
                [] -> IdentityRefusal
-> Either
     IdentityRefusal (TxIn, BabbageTxOut ConwayEra, OnChainTokenState)
forall a b. a -> Either a b
Left IdentityRefusal
StateOutputMissing
  where
    stateAddress :: Addr
stateAddress = Network -> Credential Payment -> StakeReference -> Addr
Addr Network
Ledger.Testnet (ScriptHash -> Credential Payment
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
policy) StakeReference
StakeRefNull
    holdsToken :: TxOut era -> Bool
holdsToken TxOut era
o =
        let MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
assets) = TxOut era
o TxOut era -> Getting MaryValue (TxOut era) MaryValue -> MaryValue
forall s a. s -> Getting a s a -> a
^. Getting MaryValue (TxOut era) MaryValue
(Value era -> Const MaryValue (Value era))
-> TxOut era -> Const MaryValue (TxOut era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL
        in  Bool
-> (Map AssetName Integer -> Bool)
-> Maybe (Map AssetName Integer)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                Bool
False
                ((Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (Integer -> Bool)
-> (Map AssetName Integer -> Integer)
-> Map AssetName Integer
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> AssetName -> Map AssetName Integer -> Integer
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Integer
0 (ShortByteString -> AssetName
AssetName ShortByteString
name))
                (PolicyID
-> Map PolicyID (Map AssetName Integer)
-> Maybe (Map AssetName Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScriptHash -> PolicyID
PolicyID ScriptHash
policy) Map PolicyID (Map AssetName Integer)
assets)

-- | The refusal's name, then what it found.
renderIdentityRefusal :: IdentityRefusal -> Text
renderIdentityRefusal :: IdentityRefusal -> Text
renderIdentityRefusal = \case
    StateTokenForeignRelease ScriptHash
expected ->
        Text
"state-token-foreign-release: the token's policy is not this release's state script "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
hexText (ScriptHash -> ByteString
scriptHashBytes ScriptHash
expected)
    IdentityRefusal
StateTokenNotFound ->
        Text
"state-token-not-found: the provider has no record of the asset"
    StateTokenBurned Integer
supply ->
        Text
"state-token-burned: the asset's supply is "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show Integer
supply)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", not one"
    StateTokenSeedMismatch TxId
minting ->
        Text
"state-token-seed-mismatch: the minting transaction "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#') (TxIn -> Text
renderOutRef (TxId -> TxIx -> TxIn
TxIn TxId
minting TxIx
forall a. Bounded a => a
minBound))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" spends no input whose derived name is the token's"
    IdentityRefusal
StateOutputMissing ->
        Text
"state-output-missing: no output holds the token at the state address with a state datum"
    RegistryPinMismatch PinField
field ->
        Text
"registry-pin-mismatch "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PinField -> Text
pinName PinField
field
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": the datum's "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PinField -> Text
pinName PinField
field
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" policy differs from the one the release derives for this token"
    NetworkMismatch (Network Word32
magic) ->
        Text
"network-mismatch: the provider's network (magic "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Word32 -> String
forall a. Show a => a -> String
show Word32
magic)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") is not the network of this release's addresses"
    IdentityUnreadable ReadFailure
failure ->
        Text
"the provider could not be read: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ReadFailure -> String
forall a. Show a => a -> String
show ReadFailure
failure)

-- | Why a command cannot run the scripts it needs.
data ReferenceRefusal
    = -- | No source found a carrier of this role's hash
      ReferenceMissing ReferenceRole ScriptHash
    | -- | A source could not be read
      ReferenceUnreadable ReadFailure
    deriving stock (ReferenceRefusal -> ReferenceRefusal -> Bool
(ReferenceRefusal -> ReferenceRefusal -> Bool)
-> (ReferenceRefusal -> ReferenceRefusal -> Bool)
-> Eq ReferenceRefusal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReferenceRefusal -> ReferenceRefusal -> Bool
== :: ReferenceRefusal -> ReferenceRefusal -> Bool
$c/= :: ReferenceRefusal -> ReferenceRefusal -> Bool
/= :: ReferenceRefusal -> ReferenceRefusal -> Bool
Eq, Int -> ReferenceRefusal -> ShowS
[ReferenceRefusal] -> ShowS
ReferenceRefusal -> String
(Int -> ReferenceRefusal -> ShowS)
-> (ReferenceRefusal -> String)
-> ([ReferenceRefusal] -> ShowS)
-> Show ReferenceRefusal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReferenceRefusal -> ShowS
showsPrec :: Int -> ReferenceRefusal -> ShowS
$cshow :: ReferenceRefusal -> String
show :: ReferenceRefusal -> String
$cshowList :: [ReferenceRefusal] -> ShowS
showList :: [ReferenceRefusal] -> ShowS
Show)

{- | Whether the output carries a reference script whose hash, computed here
from the script itself, is the expected one.
-}
carriesReference :: ScriptHash -> TxOut ConwayEra -> Bool
carriesReference :: ScriptHash -> TxOut ConwayEra -> Bool
carriesReference ScriptHash
expected TxOut ConwayEra
output = case TxOut ConwayEra
BabbageTxOut ConwayEra
output 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
    SJust Script ConwayEra
script -> Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script ConwayEra
script ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptHash
expected
    StrictMaybe (Script ConwayEra)
SNothing -> Bool
False

{- | Find a carrier for each needed role: from the provider's existence
query, then the actor's wallet, read only when the provider carries none
of some role. A carrier is admitted only by 'carriesReference'; among the
admitted carriers of the first source that has any, the lowest output
reference is chosen. A command that runs no reference script reads
nothing.
-}
findReferences
    :: (Monad m)
    => Session w m
    -> Maybe Addr
    -- ^ The actor's wallet, when the command has one
    -> Map ReferenceRole ScriptHash
    -> Set ReferenceRole
    -- ^ The roles the command's transaction runs
    -> m
        (Either ReferenceRefusal (Map ReferenceRole (TxIn, TxOut ConwayEra)))
findReferences :: forall (m :: * -> *) w.
Monad m =>
Session w m
-> Maybe Addr
-> Map ReferenceRole ScriptHash
-> Set ReferenceRole
-> m (Either
        ReferenceRefusal (Map ReferenceRole (TxIn, TxOut ConwayEra)))
findReferences Session w m
session Maybe Addr
walletAt Map ReferenceRole ScriptHash
expected Set ReferenceRole
needed = ExceptT
  ReferenceRefusal m (Map ReferenceRole (TxIn, TxOut ConwayEra))
-> m (Either
        ReferenceRefusal (Map ReferenceRole (TxIn, TxOut ConwayEra)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   ReferenceRefusal m (Map ReferenceRole (TxIn, TxOut ConwayEra))
 -> m (Either
         ReferenceRefusal (Map ReferenceRole (TxIn, TxOut ConwayEra))))
-> ExceptT
     ReferenceRefusal m (Map ReferenceRole (TxIn, TxOut ConwayEra))
-> m (Either
        ReferenceRefusal (Map ReferenceRole (TxIn, TxOut ConwayEra)))
forall a b. (a -> b) -> a -> b
$ do
    let wanted :: [(ReferenceRole, ScriptHash)]
wanted =
            [ (ReferenceRole
role, ScriptHash
hash)
            | ReferenceRole
role <- Set ReferenceRole -> [ReferenceRole]
forall a. Set a -> [a]
Set.toAscList Set ReferenceRole
needed
            , Just ScriptHash
hash <- [ReferenceRole -> Map ReferenceRole ScriptHash -> Maybe ScriptHash
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ReferenceRole
role Map ReferenceRole ScriptHash
expected]
            ]
        carries :: ScriptHash
-> [(a, BabbageTxOut ConwayEra)] -> [(a, BabbageTxOut ConwayEra)]
carries ScriptHash
hash = ((a, BabbageTxOut ConwayEra) -> Bool)
-> [(a, BabbageTxOut ConwayEra)] -> [(a, BabbageTxOut ConwayEra)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ScriptHash -> TxOut ConwayEra -> Bool
carriesReference ScriptHash
hash (BabbageTxOut ConwayEra -> Bool)
-> ((a, BabbageTxOut ConwayEra) -> BabbageTxOut ConwayEra)
-> (a, BabbageTxOut ConwayEra)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, BabbageTxOut ConwayEra) -> BabbageTxOut ConwayEra
forall a b. (a, b) -> b
snd)
    fromProvider <-
        ((ReferenceRole, ScriptHash)
 -> ExceptT ReferenceRefusal m [(TxIn, BabbageTxOut ConwayEra)])
-> [(ReferenceRole, ScriptHash)]
-> ExceptT ReferenceRefusal m [[(TxIn, BabbageTxOut ConwayEra)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
            ( \(ReferenceRole
_, ScriptHash
hash) ->
                ScriptHash
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall {a}.
ScriptHash
-> [(a, BabbageTxOut ConwayEra)] -> [(a, BabbageTxOut ConwayEra)]
carries ScriptHash
hash
                    ([(TxIn, BabbageTxOut ConwayEra)]
 -> [(TxIn, BabbageTxOut ConwayEra)])
-> ExceptT ReferenceRefusal m [(TxIn, BabbageTxOut ConwayEra)]
-> ExceptT ReferenceRefusal m [(TxIn, BabbageTxOut ConwayEra)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either
     ReadFailure (Evidenced w [(TxIn, BabbageTxOut ConwayEra)]))
-> ExceptT ReferenceRefusal m [(TxIn, BabbageTxOut ConwayEra)]
forall (m :: * -> *) w a.
Monad m =>
m (Either ReadFailure (Evidenced w a))
-> ExceptT ReferenceRefusal m a
readReference (Session w m
-> OutputQuery -> m (Either ReadFailure (Evidenced w Outputs))
forall w (m :: * -> *).
Session w m
-> OutputQuery -> m (Either ReadFailure (Evidenced w Outputs))
outputs Session w m
session (ScriptHash -> OutputQuery
CarryingReferenceScript ScriptHash
hash))
            )
            [(ReferenceRole, ScriptHash)]
wanted
    wallet <-
        if any null fromProvider
            then
                maybe (pure []) (readReference . outputs session . AtAddress) walletAt
            else pure []
    let choose ((ReferenceRole
role, ScriptHash
hash), [(TxIn, BabbageTxOut ConwayEra)]
provided) =
            case ([(TxIn, BabbageTxOut ConwayEra)] -> Bool)
-> [[(TxIn, BabbageTxOut ConwayEra)]]
-> [[(TxIn, BabbageTxOut ConwayEra)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([(TxIn, BabbageTxOut ConwayEra)] -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, BabbageTxOut ConwayEra)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[(TxIn, BabbageTxOut ConwayEra)]
provided, ScriptHash
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall {a}.
ScriptHash
-> [(a, BabbageTxOut ConwayEra)] -> [(a, BabbageTxOut ConwayEra)]
carries ScriptHash
hash [(TxIn, BabbageTxOut ConwayEra)]
wallet] of
                [(TxIn, BabbageTxOut ConwayEra)]
found : [[(TxIn, BabbageTxOut ConwayEra)]]
_ -> (ReferenceRole, (TxIn, BabbageTxOut ConwayEra))
-> Either
     ReferenceRefusal (ReferenceRole, (TxIn, BabbageTxOut ConwayEra))
forall a b. b -> Either a b
Right (ReferenceRole
role, ((TxIn, BabbageTxOut ConwayEra)
 -> (TxIn, BabbageTxOut ConwayEra) -> Ordering)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> (TxIn, BabbageTxOut ConwayEra)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((TxIn, BabbageTxOut ConwayEra) -> TxIn)
-> (TxIn, BabbageTxOut ConwayEra)
-> (TxIn, BabbageTxOut ConwayEra)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst) [(TxIn, BabbageTxOut ConwayEra)]
found)
                [] -> ReferenceRefusal
-> Either
     ReferenceRefusal (ReferenceRole, (TxIn, BabbageTxOut ConwayEra))
forall a b. a -> Either a b
Left (ReferenceRole -> ScriptHash -> ReferenceRefusal
ReferenceMissing ReferenceRole
role ScriptHash
hash)
    either
        throwError
        (pure . Map.fromList)
        (traverse choose (zip wanted fromProvider))

-- | A provider read, its failure a reference refusal.
readReference
    :: (Monad m)
    => m (Either ReadFailure (Evidenced w a))
    -> ExceptT ReferenceRefusal m a
readReference :: forall (m :: * -> *) w a.
Monad m =>
m (Either ReadFailure (Evidenced w a))
-> ExceptT ReferenceRefusal m a
readReference m (Either ReadFailure (Evidenced w a))
action =
    m (Either ReferenceRefusal a) -> ExceptT ReferenceRefusal m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
        ((Either ReadFailure (Evidenced w a) -> Either ReferenceRefusal a)
-> m (Either ReadFailure (Evidenced w a))
-> m (Either ReferenceRefusal a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ReadFailure -> Either ReferenceRefusal a)
-> (Evidenced w a -> Either ReferenceRefusal a)
-> Either ReadFailure (Evidenced w a)
-> Either ReferenceRefusal a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ReferenceRefusal -> Either ReferenceRefusal a
forall a b. a -> Either a b
Left (ReferenceRefusal -> Either ReferenceRefusal a)
-> (ReadFailure -> ReferenceRefusal)
-> ReadFailure
-> Either ReferenceRefusal a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadFailure -> ReferenceRefusal
ReferenceUnreadable) (a -> Either ReferenceRefusal a
forall a b. b -> Either a b
Right (a -> Either ReferenceRefusal a)
-> (Evidenced w a -> a)
-> Evidenced w a
-> Either ReferenceRefusal a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Evidenced w a -> a
forall w a. Evidenced w a -> a
value)) m (Either ReadFailure (Evidenced w a))
action)

-- | The refusal, with the remedy.
renderReferenceRefusal :: ReferenceRefusal -> Text
renderReferenceRefusal :: ReferenceRefusal -> Text
renderReferenceRefusal = \case
    ReferenceMissing ReferenceRole
role ScriptHash
hash ->
        Text
"reference-missing "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ReferenceRole -> Text
roleName ReferenceRole
role
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
hexText (ScriptHash -> ByteString
scriptHashBytes ScriptHash
hash)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": not found by this provider or wallet; publish it with singular registry publish-references"
    ReferenceUnreadable ReadFailure
failure ->
        Text
"the provider could not be read while finding references: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ReadFailure -> String
forall a. Show a => a -> String
show ReadFailure
failure)

-- | A pin field as refusals spell it.
pinName :: PinField -> Text
pinName :: PinField -> Text
pinName = \case
    PinField
PinApplication -> Text
"application"
    PinField
PinActive -> Text
"active"
    PinField
PinAbsent -> Text
"absent"
    PinField
PinTerminal -> Text
"terminal"

-- | The pin a state datum carries.
datumPin :: PinField -> OnChainTokenState -> ByteString
datumPin :: PinField -> OnChainTokenState -> ByteString
datumPin = \case
    PinField
PinApplication -> OnChainTokenState -> ByteString
stateAppPolicyBytes
    PinField
PinActive -> OnChainTokenState -> ByteString
stateActivePolicyBytes
    PinField
PinAbsent -> OnChainTokenState -> ByteString
stateAbsentPolicyBytes
    PinField
PinTerminal -> OnChainTokenState -> ByteString
stateTerminalPolicyBytes

-- | The pin a configuration derives.
configPin :: PinField -> CageConfig -> SBS.ShortByteString
configPin :: PinField -> CageConfig -> ShortByteString
configPin = \case
    PinField
PinApplication -> CageConfig -> ShortByteString
cfgApplicationPolicy
    PinField
PinActive -> CageConfig -> ShortByteString
cfgActivePolicy
    PinField
PinAbsent -> CageConfig -> ShortByteString
cfgAbsentPolicy
    PinField
PinTerminal -> CageConfig -> ShortByteString
cfgTerminalPolicy

-- | The ledger network a provider's magic names: mainnet's, or a test network.
ledgerNetwork :: Network -> Ledger.Network
ledgerNetwork :: Network -> Network
ledgerNetwork (Network Word32
magic)
    | Word32
magic Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
764_824_073 = Network
Ledger.Mainnet
    | Bool
otherwise = Network
Ledger.Testnet

hexText :: ByteString -> Text
hexText :: ByteString -> Text
hexText = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode