{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Singular.Registry.TxBuilder.Internal.Edges
Description : edge decisions, consumer binding and failure attribution
License     : Apache-2.0

One owner for the decisions a builder shares with the cage: what each
registry edge does to the trie ('walkEdge', the one place an edge and
its leaf bytes are paired), what an edge owes the mint ('deltaOf',
'policyOfKind', 'approvalName'), the pinned consumer binding
('ConsumerBinding', 'deriveConsumerBinding', 'mkConsumerScript'), and
node and builder-evaluation failure attribution ('failedWitnessHash',
'evalScriptHash', 'isBudgetFailure').

This is the edges-and-binding owner extracted from
@Singular.Registry.TxBuilder.Internal@; the public module re-exports
it and is its only intended consumer surface.
-}
module Singular.Registry.TxBuilder.Internal.Edges
    ( -- * Registry-mode edges (#157 seven-admitted-edges)
      leafAbsent
    , leafActive
    , leafTerminal
    , walkEdge
    , deltaOf
    , policyOfKind
    , approvalName
    , approvalDestination
    , destinationDatumHash

      -- * Pinned-hook invocation (NOTE-021)
    , pinScriptHash
    , hookAccountAddress
    , keyAccountAddress
    , ConsumerBinding (..)
    , deriveConsumerBinding
    , mkConsumerScript

      -- * Failure attribution (NOTE-023)
    , failedWitnessHash
    , evalScriptHash
    , isBudgetFailure
    ) where

import Cardano.Crypto.Hash
    ( Blake2b_256
    , hashFromBytes
    , hashToBytes
    , hashWith
    )
import Cardano.Ledger.Address (AccountAddress (..), AccountId (..))
import Cardano.Ledger.BaseTypes (Network)
import Cardano.Ledger.Core (Script)
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Hashes (ScriptHash (..), extractHash)
import Cardano.Ledger.Keys
    ( KeyHash (..)
    , KeyRole (..)
    )
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Short qualified as SBS
import Data.Char (isHexDigit)
import Data.Coerce (coerce)
import Data.List (isInfixOf, isPrefixOf, tails)
import Data.Maybe (fromMaybe)
import PlutusCore.Data qualified as PLC
import Singular.Registry.Config (CageConfig (..))
import Singular.Registry.Ledger (ConwayEra)
import Singular.Registry.Trie (Trie (..))
import Singular.Registry.TxBuilder.Internal.Identity
    ( computeScriptHash
    , scriptFromBytes
    , scriptHashBytes
    )
import Singular.Registry.Types
    ( Edge
    , ProofStep
    , edgeInsertActive
    , edgeUpdateTerminal
    )

-- ---------------------------------------------------------
-- Registry-mode edges (#157 seven-admitted-edges)
-- ---------------------------------------------------------

{- | The three leaf states the registry admits (#157 three-state-leaf-codec). Requests
carry an edge, not a value, so these are no longer something a builder
chooses: they are the bytes each edge's trie move reads and writes, and
'walkEdge' below is the one place that pairs them with their edge.
-}
leafAbsent, leafActive, leafTerminal :: ByteString
leafAbsent :: ByteString
leafAbsent = Word8 -> ByteString
BS.singleton Word8
0x00
leafActive :: ByteString
leafActive = Word8 -> ByteString
BS.singleton Word8
0x01
leafTerminal :: ByteString
leafTerminal = Word8 -> ByteString
BS.singleton Word8
0x02

{- | Walk one request's edge through a speculative trie and return the
proof steps the fold states for it (#183).

The edge names the move and its leaf bytes, from the table `types.ak`
publishes. The proof is the one the cage verifies at this request's own
position in the batch, so it is read BEFORE a replacement
and AFTER an insert, exactly as the cage's own walk does.

A tag outside the table names no move: the cage refuses it
`edge-inadmissible` before touching the trie, so the builder walks
nothing either and states the proof the refusal will be judged against.
All five excluded encodings leave the local trie unchanged for refusal fixtures.

One site, so the connected fold and the update builder cannot drift
apart about what an edge does to the trie.
-}
walkEdge :: (Monad m) => Trie m -> ByteString -> Edge -> m [ProofStep]
walkEdge :: forall (m :: * -> *).
Monad m =>
Trie m -> ByteString -> Integer -> m [ProofStep]
walkEdge Trie m
trie ByteString
key Integer
edge
    | Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
edgeInsertActive = ByteString -> m [ProofStep]
inserting ByteString
leafActive
    | Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
edgeUpdateTerminal = ByteString -> m [ProofStep]
replacing ByteString
leafTerminal
    | Bool
otherwise = m [ProofStep]
steps
  where
    steps :: m [ProofStep]
steps = [ProofStep] -> Maybe [ProofStep] -> [ProofStep]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [ProofStep] -> [ProofStep])
-> m (Maybe [ProofStep]) -> m [ProofStep]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Trie m -> ByteString -> m (Maybe [ProofStep])
forall (m :: * -> *). Trie m -> ByteString -> m (Maybe [ProofStep])
getProofSteps Trie m
trie ByteString
key
    inserting :: ByteString -> m [ProofStep]
inserting ByteString
leaf = do
        _ <- Trie m -> ByteString -> ByteString -> m Root
forall (m :: * -> *). Trie m -> ByteString -> ByteString -> m Root
insert Trie m
trie ByteString
key ByteString
leaf
        steps
    replacing :: ByteString -> m [ProofStep]
replacing ByteString
leaf = do
        before <- m [ProofStep]
steps
        _ <- delete trie key
        _ <- insert trie key leaf
        pure before

{- | What a supported edge owes the mint, as @(kind, quantity)@.
Registration mints one active token (kind 1); retirement burns one.
-}
deltaOf :: Integer -> [(Integer, Integer)]
deltaOf :: Integer -> [(Integer, Integer)]
deltaOf Integer
edge = case Integer
edge of
    Integer
1 -> [(Integer
1, Integer
1)]
    Integer
3 -> [(Integer
1, -Integer
1)]
    Integer
_ -> []

-- | The policy a kind names in this registry's configuration.
policyOfKind :: CageConfig -> Integer -> SBS.ShortByteString
policyOfKind :: CageConfig -> Integer -> ShortByteString
policyOfKind CageConfig
cfg Integer
kind = case Integer
kind of
    Integer
0 -> CageConfig -> ShortByteString
cfgAbsentPolicy CageConfig
cfg
    Integer
1 -> CageConfig -> ShortByteString
cfgActivePolicy CageConfig
cfg
    Integer
2 -> CageConfig -> ShortByteString
cfgTerminalPolicy CageConfig
cfg
    Integer
_ -> [Char] -> ShortByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"policyOfKind: not a token kind"

{- | The approval binding (#157 approval-asset-binding): the asset name the application
policy mints to certify one edge, @blake2b_256(edge ‖ key ‖ owner ‖
destination address ‖ destination datum hash)@. One formula, recomputed by
the cage from the request it rides; a builder that computes it differently
makes an honest booking refuse loudly at the fold.
-}
approvalName
    :: Integer
    -> ByteString
    -- ^ Registry key
    -> ByteString
    -- ^ Owner (the payment key hash the approval binds)
    -> (ByteString, ByteString)
    -- ^ Destination: address bytes and datum hash
    -> ByteString
approvalName :: Integer
-> ByteString
-> ByteString
-> (ByteString, ByteString)
-> ByteString
approvalName Integer
edge ByteString
key ByteString
owner (ByteString
destAddr, ByteString
datumHash) =
    ByteString -> ByteString
blake2b256
        ( Word8 -> ByteString
BS.singleton (Integer -> Word8
forall a. Num a => Integer -> a
fromInteger Integer
edge)
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
key
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
owner
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
destAddr
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
datumHash
        )

{- | The hash an approval binds for the datum a request carries (#419): the
BLAKE2b-256 of the datum's serialisation, empty for none — the bytes the
request named before it carried the datum, so an approval's name is
unchanged for the same tuple.
-}
destinationDatumHash :: Maybe PLC.Data -> ByteString
destinationDatumHash :: Maybe Data -> ByteString
destinationDatumHash =
    ByteString -> (Data -> ByteString) -> Maybe Data -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        ByteString
BS.empty
        ( \Data
datum ->
            Hash Blake2b_256 EraIndependentData -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (SafeHash EraIndependentData -> Hash Blake2b_256 EraIndependentData
forall i. SafeHash i -> Hash Blake2b_256 i
extractHash (Data ConwayEra -> SafeHash EraIndependentData
forall era. Data era -> SafeHash EraIndependentData
hashData (Data -> Data ConwayEra
forall era. Era era => Data -> Data era
Data Data
datum :: Data ConwayEra)))
        )

-- | A request's destination as 'approvalName' binds it.
approvalDestination
    :: (ByteString, Maybe PLC.Data) -> (ByteString, ByteString)
approvalDestination :: (ByteString, Maybe Data) -> (ByteString, ByteString)
approvalDestination (ByteString
address, Maybe Data
datum) = (ByteString
address, Maybe Data -> ByteString
destinationDatumHash Maybe Data
datum)

blake2b256 :: ByteString -> ByteString
blake2b256 :: ByteString -> ByteString
blake2b256 = Hash Blake2b_256 ByteString -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (Hash Blake2b_256 ByteString -> ByteString)
-> (ByteString -> Hash Blake2b_256 ByteString)
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
hashWith @Blake2b_256 ByteString -> ByteString
forall a. a -> a
id

-- ---------------------------------------------------------
-- Pinned-hook invocation (NOTE-020 item 1)
-- ---------------------------------------------------------

{- | The consumer pin as a ledger 'ScriptHash'. Loud on bad width
(the mint gate enforces 28 bytes on chain; this mirrors it
builder-side so a misconfigured pin fails at build, not on
ledger).
-}
pinScriptHash :: ByteString -> ScriptHash
pinScriptHash :: ByteString -> ScriptHash
pinScriptHash ByteString
bs = case ByteString -> Maybe (Hash ADDRHASH EraIndependentScript)
forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
hashFromBytes ByteString
bs of
    Just Hash ADDRHASH EraIndependentScript
h -> Hash ADDRHASH EraIndependentScript -> ScriptHash
ScriptHash Hash ADDRHASH EraIndependentScript
h
    Maybe (Hash ADDRHASH EraIndependentScript)
Nothing ->
        [Char] -> ScriptHash
forall a. HasCallStack => [Char] -> a
error
            [Char]
"pinScriptHash: consumer pin must be 28 bytes"

{- | The withdrawal account for the pinned consumer: the exact script
credential from the pin, on the cage's network.
-}
hookAccountAddress :: Network -> ByteString -> AccountAddress
hookAccountAddress :: Network -> ByteString -> AccountAddress
hookAccountAddress Network
net ByteString
pinBs =
    Network -> AccountId -> AccountAddress
AccountAddress Network
net (Credential Staking -> AccountId
AccountId (ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ByteString -> ScriptHash
pinScriptHash ByteString
pinBs)))

{- | A key-hash withdrawal account (exhibit controls only): lets a
row point a withdrawal at an ordinary key, where no script executes
and only the cage's own credential check can refuse. Loud on bad
width, like the pin helper above.
-}
keyAccountAddress :: Network -> ByteString -> AccountAddress
keyAccountAddress :: Network -> ByteString -> AccountAddress
keyAccountAddress Network
net ByteString
khBs = case ByteString -> Maybe (Hash ADDRHASH (VerKeyDSIGN DSIGN))
forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
hashFromBytes ByteString
khBs of
    Just Hash ADDRHASH (VerKeyDSIGN DSIGN)
h ->
        Network -> AccountId -> AccountAddress
AccountAddress
            Network
net
            ( Credential Staking -> AccountId
AccountId
                ( KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj
                    (KeyHash Payment -> KeyHash Staking
forall a b. Coercible a b => a -> b
coerce (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash Payment
forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
KeyHash Hash ADDRHASH (VerKeyDSIGN DSIGN)
h :: KeyHash Payment))
                )
            )
    Maybe (Hash ADDRHASH (VerKeyDSIGN DSIGN))
Nothing ->
        [Char] -> AccountAddress
forall a. HasCallStack => [Char] -> a
error
            [Char]
"keyAccountAddress: key hash must be 28 bytes"

{- | The bound exhibit consumer, unparameterized (NOTE-021): no
operator key, no appointed processor — the consumer authenticates
batches from transaction evidence alone. One derivation, used for
boot pinning, builder witnesses, and identity checks — never separate
computations that could disagree.
-}
data ConsumerBinding = ConsumerBinding
    { ConsumerBinding -> ShortByteString
cbPin :: SBS.ShortByteString
    , ConsumerBinding -> ShortByteString
cbScriptBytes :: SBS.ShortByteString
    , ConsumerBinding -> Script ConwayEra
cbScript :: Script ConwayEra
    , ConsumerBinding -> ScriptHash
cbHash :: ScriptHash
    }

deriveConsumerBinding
    :: SBS.ShortByteString -> ConsumerBinding
deriveConsumerBinding :: ShortByteString -> ConsumerBinding
deriveConsumerBinding ShortByteString
unapplied =
    let h :: ScriptHash
h = ShortByteString -> ScriptHash
computeScriptHash ShortByteString
unapplied
    in  ShortByteString
-> ShortByteString
-> Script ConwayEra
-> ScriptHash
-> ConsumerBinding
ConsumerBinding
            (ByteString -> ShortByteString
SBS.toShort (ScriptHash -> ByteString
scriptHashBytes ScriptHash
h))
            ShortByteString
unapplied
            ([Char] -> ShortByteString -> Script ConwayEra
scriptFromBytes [Char]
"consumer" ShortByteString
unapplied)
            ScriptHash
h

{- | Build the bound consumer 'Script' from config bytes (mirror of
'mkCageScript'). Builders attach this as the hook withdrawal witness.
-}
mkConsumerScript :: CageConfig -> Script ConwayEra
mkConsumerScript :: CageConfig -> Script ConwayEra
mkConsumerScript CageConfig
cfg =
    [Char] -> ShortByteString -> Script ConwayEra
scriptFromBytes
        [Char]
"mkConsumerScript"
        (CageConfig -> ShortByteString
cfgConsumerScript CageConfig
cfg)

-- ---------------------------------------------------------
-- Failure attribution (NOTE-023 item 2)
-- ---------------------------------------------------------

{- | Parse the node's named failed-witness field
(@The script hash is:ScriptHash "HEX"@) and return the hash — the
FIRST occurrence, which names the failing script (later occurrences
repeat the same failure's context). Anchored on the opening quote
(hash letters also occur in @ScriptHash@ itself, so a hex scan from
the marker misfires). Length-checked to 56 hex chars (a 28-byte
script hash) so partial garbage never matches. @Nothing@ when the
reason carries no named field (non-script failures: extraneous
witnesses, unregistered withdrawals, balance errors).
-}
failedWitnessHash :: String -> Maybe String
failedWitnessHash :: [Char] -> Maybe [Char]
failedWitnessHash [Char]
s =
    case [Char] -> [Char] -> Maybe [Char]
findAfter [Char]
"The script hash is:" [Char]
s of
        Maybe [Char]
Nothing -> Maybe [Char]
forall a. Maybe a
Nothing
        Just [Char]
rest -> case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') [Char]
rest of
            (Char
'"' : [Char]
after) ->
                let hex :: [Char]
hex = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isHexDigit [Char]
after
                in  if [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
hex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
56 then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
hex else Maybe [Char]
forall a. Maybe a
Nothing
            [Char]
_ -> Maybe [Char]
forall a. Maybe a
Nothing

{- | Parse a builder-EVALUATION failure's named script field
(@pwcScriptHash = ScriptHash "HEX"@, first occurrence) and return
the hash. NOTE-018 bind: fork-occupied assertions match THIS field
against the derived applied identity — never a hex substring of the
full @ErrorCall@ show (transaction data, values and parameterized
script bytes can all contain the state policy). Same 56-hex rule.
-}
evalScriptHash :: String -> Maybe String
evalScriptHash :: [Char] -> Maybe [Char]
evalScriptHash [Char]
s =
    case [Char] -> [Char] -> Maybe [Char]
findAfter [Char]
"pwcScriptHash = ScriptHash" [Char]
s of
        Maybe [Char]
Nothing -> Maybe [Char]
forall a. Maybe a
Nothing
        Just [Char]
rest -> case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') [Char]
rest of
            (Char
'"' : [Char]
after) ->
                let hex :: [Char]
hex = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isHexDigit [Char]
after
                in  if [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
hex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
56 then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
hex else Maybe [Char]
forall a. Maybe a
Nothing
            [Char]
_ -> Maybe [Char]
forall a. Maybe a
Nothing

findAfter :: String -> String -> Maybe String
findAfter :: [Char] -> [Char] -> Maybe [Char]
findAfter [Char]
needle [Char]
hay =
    case [ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
needle) [Char]
t
         | [Char]
t <- [Char] -> [[Char]]
forall a. [a] -> [[a]]
tails [Char]
hay
         , [Char]
needle [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
t
         ] of
        ([Char]
r : [[Char]]
_) -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
r
        [] -> Maybe [Char]
forall a. Maybe a
Nothing

{- | True when the refusal is budget exhaustion rather than a semantic
predicate failure. Kept to the OBSERVED node wording
(@overspending the budget@); unknown budget wordings fail closed
elsewhere (no named semantic match), never silently accepted.
-}
isBudgetFailure :: String -> Bool
isBudgetFailure :: [Char] -> Bool
isBudgetFailure [Char]
s = [Char]
"overspending the budget" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
s