{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{- | Application proofs for one registry's independently selected state.
Unbound selections record observations without promising an atomic ledger
snapshot. Coverage is checked from create and reproduced trie-changing roots.
-}
module Singular.Registry.TrieState
    ( StatePolicyId (..)
    , RegistryIdentity (..)
    , SessionId (..)
    , SessionBinding (..)
    , StatePoint (..)
    , TrieSelection (..)
    , TrieState (..)
    , TrieSnapshot
    , trieIdentity
    , triePoint
    , trieRoot
    , trieCoverage
    , trieLineage
    , leafAt
    , membership
    , nonMembership
    , speculateEdges
    , Leaf (..)
    , leafName
    , TrieFailure (..)
    , Parting (..)
    , Incomplete (..)
    , Undecodable (..)
    , Mismatch (..)
    , Staleness (..)
    , Missing (..)
    , failureRegistry
    , failureTransaction
    , trieFailureName
    , trieFailureFields
    , CompleteFromCreate
    , coverageTransitions
    , MembershipProof
    , membershipBytes
    , NonMembershipProof
    , verifyNonMembership
    , PublicLineage (..)
    , SpeculativeWalk
    , walkRoot
    , walkProofs
    , CreateRecord (..)
    , ObservedFold (..)
    , TrieObservation (..)
    ) where

import Data.Aeson (Value, object, toJSON, (.=))
import Data.Aeson.Key qualified as Key
import Data.ByteString (ByteString)
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Short qualified as SBS
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Text qualified as T

import Cardano.Crypto.Hash (hashToBytes)
import Cardano.Ledger.Hashes (extractHash)
import Cardano.Ledger.TxIn (TxId (..))

import Singular.Registry.Deployment.Manifest (renderOutRef)
import Singular.Registry.Ledger (AssetName (..), Root (..))
import Singular.Registry.Trie.Pure (verifyExclusion)
import Singular.Registry.TrieState.Types

{- | The proof's key is the one the backend actually queried. Its constructor
is private; changing either the requested key or selected root fails.
-}
verifyNonMembership
    :: NonMembershipProof -> Root -> ByteString -> Bool
verifyNonMembership :: NonMembershipProof -> Root -> ByteString -> Bool
verifyNonMembership (NonMembershipProof ByteString
provenKey MPFExclusionProof MPFHash
proof) (Root ByteString
root) ByteString
key =
    ByteString
key ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
provenKey Bool -> Bool -> Bool
&& MPFExclusionProof MPFHash -> ByteString -> Bool
verifyExclusion MPFExclusionProof MPFHash
proof ByteString
root

-- Public observers are functions, not exported record labels. A caller cannot
-- construct a snapshot or copy a certificate into another selection.
trieIdentity :: TrieSnapshot m -> RegistryIdentity
trieIdentity :: forall (m :: * -> *). TrieSnapshot m -> RegistryIdentity
trieIdentity = TrieSnapshot m -> RegistryIdentity
forall (m :: * -> *). TrieSnapshot m -> RegistryIdentity
snapshotTrieIdentity
triePoint :: TrieSnapshot m -> StatePoint
triePoint :: forall (m :: * -> *). TrieSnapshot m -> StatePoint
triePoint = TrieSnapshot m -> StatePoint
forall (m :: * -> *). TrieSnapshot m -> StatePoint
snapshotTriePoint
trieRoot :: TrieSnapshot m -> Root
trieRoot :: forall (m :: * -> *). TrieSnapshot m -> Root
trieRoot = TrieSnapshot m -> Root
forall (m :: * -> *). TrieSnapshot m -> Root
snapshotTrieRoot
trieCoverage :: TrieSnapshot m -> CompleteFromCreate
trieCoverage :: forall (m :: * -> *). TrieSnapshot m -> CompleteFromCreate
trieCoverage = TrieSnapshot m -> CompleteFromCreate
forall (m :: * -> *). TrieSnapshot m -> CompleteFromCreate
snapshotTrieCoverage

-- | The public lineage the snapshot was replayed from, or nothing for a fixture snapshot.
trieLineage :: TrieSnapshot m -> Maybe PublicLineage
trieLineage :: forall (m :: * -> *). TrieSnapshot m -> Maybe PublicLineage
trieLineage = TrieSnapshot m -> Maybe PublicLineage
forall (m :: * -> *). TrieSnapshot m -> Maybe PublicLineage
snapshotTrieLineage

leafAt :: TrieSnapshot m -> ByteString -> m (Either TrieFailure Leaf)
leafAt :: forall (m :: * -> *).
TrieSnapshot m -> ByteString -> m (Either TrieFailure Leaf)
leafAt = TrieSnapshot m -> ByteString -> m (Either TrieFailure Leaf)
forall (m :: * -> *).
TrieSnapshot m -> ByteString -> m (Either TrieFailure Leaf)
snapshotLeafAt
membership
    :: TrieSnapshot m
    -> ByteString
    -> Leaf
    -> m (Either TrieFailure MembershipProof)
membership :: forall (m :: * -> *).
TrieSnapshot m
-> ByteString -> Leaf -> m (Either TrieFailure MembershipProof)
membership = TrieSnapshot m
-> ByteString -> Leaf -> m (Either TrieFailure MembershipProof)
forall (m :: * -> *).
TrieSnapshot m
-> ByteString -> Leaf -> m (Either TrieFailure MembershipProof)
snapshotMembership
nonMembership
    :: TrieSnapshot m
    -> ByteString
    -> m (Either TrieFailure NonMembershipProof)
nonMembership :: forall (m :: * -> *).
TrieSnapshot m
-> ByteString -> m (Either TrieFailure NonMembershipProof)
nonMembership = TrieSnapshot m
-> ByteString -> m (Either TrieFailure NonMembershipProof)
forall (m :: * -> *).
TrieSnapshot m
-> ByteString -> m (Either TrieFailure NonMembershipProof)
snapshotNonMembership
speculateEdges
    :: TrieSnapshot m
    -> NonEmpty (ByteString, Integer)
    -> m (Either TrieFailure SpeculativeWalk)
speculateEdges :: forall (m :: * -> *).
TrieSnapshot m
-> NonEmpty (ByteString, Integer)
-> m (Either TrieFailure SpeculativeWalk)
speculateEdges = TrieSnapshot m
-> NonEmpty (ByteString, Integer)
-> m (Either TrieFailure SpeculativeWalk)
forall (m :: * -> *).
TrieSnapshot m
-> NonEmpty (ByteString, Integer)
-> m (Either TrieFailure SpeculativeWalk)
snapshotSpeculateEdges

-- | The registry a refusal is about.
failureRegistry :: TrieFailure -> RegistryIdentity
failureRegistry :: TrieFailure -> RegistryIdentity
failureRegistry = \case
    HistoryIncomplete RegistryIdentity
who Maybe TxId
_ Incomplete
_ -> RegistryIdentity
who
    RootDoesNotChain RegistryIdentity
who Maybe TxId
_ Parting
_ -> RegistryIdentity
who
    UndecodableRequest RegistryIdentity
who Maybe TxId
_ Undecodable
_ -> RegistryIdentity
who
    WrongRegistry RegistryIdentity
who Maybe TxId
_ Mismatch
_ -> RegistryIdentity
who
    StaleState RegistryIdentity
who Maybe TxId
_ Staleness
_ -> RegistryIdentity
who
    MissingProof RegistryIdentity
who Missing
_ -> RegistryIdentity
who

-- | The transaction a refusal is about, where one is known.
failureTransaction :: TrieFailure -> Maybe TxId
failureTransaction :: TrieFailure -> Maybe TxId
failureTransaction = \case
    HistoryIncomplete RegistryIdentity
_ Maybe TxId
tx Incomplete
_ -> Maybe TxId
tx
    RootDoesNotChain RegistryIdentity
_ Maybe TxId
tx Parting
_ -> Maybe TxId
tx
    UndecodableRequest RegistryIdentity
_ Maybe TxId
tx Undecodable
_ -> Maybe TxId
tx
    WrongRegistry RegistryIdentity
_ Maybe TxId
tx Mismatch
_ -> Maybe TxId
tx
    StaleState RegistryIdentity
_ Maybe TxId
tx Staleness
_ -> Maybe TxId
tx
    MissingProof RegistryIdentity
_ Missing
_ -> Maybe TxId
forall a. Maybe a
Nothing

-- | The refusal's name, as a command prints it.
trieFailureName :: TrieFailure -> Text
trieFailureName :: TrieFailure -> Text
trieFailureName = \case
    HistoryIncomplete{} -> Text
"HistoryIncomplete"
    RootDoesNotChain{} -> Text
"RootDoesNotChain"
    UndecodableRequest{} -> Text
"UndecodableRequest"
    WrongRegistry{} -> Text
"WrongRegistry"
    StaleState{} -> Text
"StaleState"
    MissingProof{} -> Text
"MissingProof"

{- | The receipt field a command prints beside the refusal's name: one
@trieRefusal@ object holding the registry, the transaction where one is
known, and the cause. Held under one key, it never overwrites a field the
command's receipt already carries.
-}
trieFailureFields :: TrieFailure -> [(Text, Value)]
trieFailureFields :: TrieFailure -> [(Text, Value)]
trieFailureFields TrieFailure
failure = [(Text
"trieRefusal", [Pair] -> Value
object [(Text -> Key
Key.fromText Text
k, Value
v) | (Text
k, Value
v) <- [(Text, Value)]
payload])]
  where
    payload :: [(Text, Value)]
payload =
        (Text
"registry", RegistryIdentity -> Value
registryJson (TrieFailure -> RegistryIdentity
failureRegistry TrieFailure
failure))
            (Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
: [(Text, Value)]
-> (TxId -> [(Text, Value)]) -> Maybe TxId -> [(Text, Value)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                []
                (\TxId
tx -> [(Text
"transaction", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (TxId -> Text
txIdText TxId
tx))])
                (TrieFailure -> Maybe TxId
failureTransaction TrieFailure
failure)
                [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Value)]
reasonFields
    reasonFields :: [(Text, Value)]
reasonFields = case TrieFailure
failure of
        HistoryIncomplete RegistryIdentity
_ Maybe TxId
_ Incomplete
why -> case Incomplete
why of
            Incomplete
MissingTransaction -> Text -> [(Text, Value)]
reason Text
"missing-transaction"
            ProviderHistoryFailure HistoryFailure
providerFailure ->
                Text -> [(Text, Value)]
reason Text
"provider-history-failure"
                    [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"providerFailure", String -> Value
forall a. ToJSON a => a -> Value
toJSON (HistoryFailure -> String
forall a. Show a => a -> String
show HistoryFailure
providerFailure))]
            UnresolvedInput TxIn
i -> Text -> [(Text, Value)]
reason Text
"unresolved-input" [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> TxIn -> [(Text, Value)]
forall {a}. IsString a => TxIn -> [(a, Value)]
output TxIn
i
            ConflictingResolution TxIn
i -> Text -> [(Text, Value)]
reason Text
"conflicting-resolution" [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> TxIn -> [(Text, Value)]
forall {a}. IsString a => TxIn -> [(a, Value)]
output TxIn
i
            Incomplete
ConflictingCopies -> Text -> [(Text, Value)]
reason Text
"conflicting-copies"
            Incomplete
NoStateInput -> Text -> [(Text, Value)]
reason Text
"no-state-input"
            ForkedStateOutput TxIn
i -> Text -> [(Text, Value)]
reason Text
"forked-state-output" [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> TxIn -> [(Text, Value)]
forall {a}. IsString a => TxIn -> [(a, Value)]
output TxIn
i
            Incomplete
OutsideLineage -> Text -> [(Text, Value)]
reason Text
"outside-lineage"
        RootDoesNotChain RegistryIdentity
_ Maybe TxId
_ (UnreadableRoot Text
what) ->
            Text -> [(Text, Value)]
reason Text
"unreadable-root" [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"record", Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
what)]
        RootDoesNotChain RegistryIdentity
_ Maybe TxId
_ (RootsPart Root
rebuilt Root
recorded) ->
            Text -> [(Text, Value)]
reason Text
"roots-part"
                [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
"rebuiltRoot", Root -> Value
rootJson Root
rebuilt)
                   , (Text
"recordedRoot", Root -> Value
rootJson Root
recorded)
                   ]
        UndecodableRequest RegistryIdentity
_ Maybe TxId
_ Undecodable
why -> case Undecodable
why of
            Undecodable
UndecodableStateOutput -> Text -> [(Text, Value)]
reason Text
"undecodable-state-output"
            Undecodable
MissingRedeemer -> Text -> [(Text, Value)]
reason Text
"missing-redeemer"
            Undecodable
NotModify -> Text -> [(Text, Value)]
reason Text
"not-modify"
            ActionCount Int
given Int
found ->
                Text -> [(Text, Value)]
reason Text
"action-count"
                    [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"actions", Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
given), (Text
"requests", Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
found)]
            EdgeOutOfRange Integer
edge -> Text -> [(Text, Value)]
reason Text
"edge-out-of-range" [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"edge", Integer -> Value
forall a. ToJSON a => a -> Value
toJSON Integer
edge)]
            UnreadableRecord Text
what -> Text -> [(Text, Value)]
reason Text
"unreadable-record" [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"record", Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
what)]
        WrongRegistry RegistryIdentity
_ Maybe TxId
_ Mismatch
why -> case Mismatch
why of
            Mismatch
SelectionNotState -> Text -> [(Text, Value)]
reason Text
"selection-not-state"
            Mismatch
CreateMint -> Text -> [(Text, Value)]
reason Text
"create-mint"
            Mismatch
SeedNotSpent -> Text -> [(Text, Value)]
reason Text
"seed-not-spent"
            Mismatch
SeedName -> Text -> [(Text, Value)]
reason Text
"seed-name"
            Mismatch
CreateOutput -> Text -> [(Text, Value)]
reason Text
"create-output"
            OtherRegistry RegistryIdentity
other ->
                Text -> [(Text, Value)]
reason Text
"other-registry" [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"otherRegistry", RegistryIdentity -> Value
registryJson RegistryIdentity
other)]
            Mismatch
UnknownRegistry -> Text -> [(Text, Value)]
reason Text
"unknown-registry"
        StaleState RegistryIdentity
_ Maybe TxId
_ Staleness
why -> case Staleness
why of
            StaleRoot Root
selected Root
current ->
                Text -> [(Text, Value)]
reason Text
"stale-root"
                    [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
"selectedRoot", Root -> Value
rootJson Root
selected)
                       , (Text
"currentRoot", Root -> Value
rootJson Root
current)
                       ]
            StaleSelection TrieSelection
selected TrieSelection
held ->
                Text -> [(Text, Value)]
reason Text
"stale-selection"
                    [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"selected", TrieSelection -> Value
selectionJson TrieSelection
selected), (Text
"held", TrieSelection -> Value
selectionJson TrieSelection
held)]
            StaleOutput TxIn
selected TxIn
made ->
                Text -> [(Text, Value)]
reason Text
"stale-output"
                    [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
"selectedOutput", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (TxIn -> Text
renderOutRef TxIn
selected))
                       , (Text
"madeOutput", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (TxIn -> Text
renderOutRef TxIn
made))
                       ]
            Staleness
NoSelection -> Text -> [(Text, Value)]
reason Text
"no-selection"
        MissingProof RegistryIdentity
_ Missing
why -> case Missing
why of
            NoProofFor ByteString
key -> Text -> [(Text, Value)]
reason Text
"no-proof" [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"key", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (ByteString -> Text
hexText ByteString
key))]
            Missing
NoLocalTrie -> Text -> [(Text, Value)]
reason Text
"no-local-trie"
    reason :: Text -> [(Text, Value)]
    reason :: Text -> [(Text, Value)]
reason Text
r = [(Text
"cause", Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
r)]
    output :: TxIn -> [(a, Value)]
output TxIn
i = [(a
"output", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (TxIn -> Text
renderOutRef TxIn
i))]

registryJson :: RegistryIdentity -> Value
registryJson :: RegistryIdentity -> Value
registryJson (RegistryIdentity (StatePolicyId ByteString
policy) (AssetName ShortByteString
name)) =
    [Pair] -> Value
object
        [Key
"policy" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
hexText ByteString
policy, Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
hexText (ShortByteString -> ByteString
SBS.fromShort ShortByteString
name)]

selectionJson :: TrieSelection -> Value
selectionJson :: TrieSelection -> Value
selectionJson TrieSelection{StatePoint
trieSelectionPoint :: StatePoint
trieSelectionPoint :: TrieSelection -> StatePoint
trieSelectionPoint, Root
trieSelectionRoot :: Root
trieSelectionRoot :: TrieSelection -> Root
trieSelectionRoot} =
    [Pair] -> Value
object
        [ Key
"output" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TxIn -> Text
renderOutRef (StatePoint -> TxIn
pointOutput StatePoint
trieSelectionPoint)
        , Key
"root" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Root -> Text
unRootHex Root
trieSelectionRoot
        ]

rootJson :: Root -> Value
rootJson :: Root -> Value
rootJson = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Root -> Text) -> Root -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Root -> Text
unRootHex

unRootHex :: Root -> Text
unRootHex :: Root -> Text
unRootHex (Root ByteString
r) = ByteString -> Text
hexText ByteString
r

txIdText :: TxId -> Text
txIdText :: TxId -> Text
txIdText (TxId SafeHash EraIndependentTxBody
h) = ByteString -> Text
hexText (Hash HASH EraIndependentTxBody -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody
forall i. SafeHash i -> Hash HASH i
extractHash SafeHash EraIndependentTxBody
h))

hexText :: ByteString -> Text
hexText :: ByteString -> Text
hexText = String -> Text
T.pack (String -> Text) -> (ByteString -> String) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BC.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode