{-# LANGUAGE LambdaCase #-}

{- |
Module      : Conformance.Receipt
Description : Run receipts: the only way a row becomes executed
License     : Apache-2.0

A receipt is written by a @run@ that actually executed a row,
recording the row id, the outcome, the transaction ids the chain
accepted or the refusal attribution, the measured execution units
and size, the base commit, and the node and blueprint identities.
@list@ prints a row as executed iff a receipt for it exists and its
base matches the current tree; otherwise it prints the declared
plan. Receipts live under the run's own output directory — never in
the tracked tree — and @list@ takes the directory as @--receipts@
or @CONFORMANCE_RECEIPTS@, defaulting to none.

Two venues need no node. blueprint-encoding-round-trip checks Haskell encodings against the
compiled blueprint's declared schemas read at run time
(@blueprint-check@); script-parameter-application checks parameter application in Haskell
(@param-check@). Both record @mem@/@cpu@ zero — no script executed
— and @txSize@ the measured serialized bytes, with no transactions.
Every other accepted row is a @node-submit@ observation with
transactions and units from the running node.

One shape here is owned elsewhere and re-exported: the asset-movement
form of edge evidence — a policy, a name and a quantity with their JSON
encoding — lives in @Conformance.Evidence.Asset@ and is re-exported by
this module unchanged, so the public import path a caller already uses
does not move.
-}
module Conformance.Receipt
    ( Outcome (..)
    , Verdict (..)
    , UnmetRuling (..)
    , unmetRuling
    , unmetReading
    , RefusalInfo (..)
    , ReplayEvidence (..)
    , ReplayCorrespondence (..)
    , stepReplay
    , storyCorrespondence
    , ConstructorStanding (..)
    , ConstructorEvidence (..)
    , PartialInfo (..)
    , DerivationOutcome (..)
    , AssetEntry (..)
    , DerivationEvidence (..)
    , derivationMatches
    , Receipt (..)
    , declaredConstructors
    , derivationVenue
    , maxReceiptBytes
    , maxLiveStepReasonChars
    , checkReceiptSize
    , loadReceipts
    , writeReceiptFile
    , currentBase
    ) where

import Conformance.Edge.Programs (programFor)
import Conformance.Evidence.Asset (AssetEntry (..))
import Conformance.NodeRejection (boundedNodeReason)
import Conformance.Replay
    ( ReplayCorrespondence (..)
    , ReplayEvidence (..)
    , causeName
    )
import Conformance.RowNames (canonicalRowName)
import Conformance.Story.Live
    ( BatchTamper (..)
    , Edge (..)
    , RefundTamper (..)
    , Tamper (..)
    , batchTamperName
    , edgeName
    , refundTamperName
    , tamperName
    )
import Control.Exception (ErrorCall (..), throwIO)

import Data.Aeson
    ( FromJSON (..)
    , Result (..)
    , ToJSON (..)
    , Value (..)
    , eitherDecode
    , encode
    , fromJSON
    , object
    , withObject
    , withText
    , (.!=)
    , (.:)
    , (.:?)
    , (.=)
    )
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KM
import Data.ByteString.Lazy qualified as BSL
import Data.List (isPrefixOf, isSuffixOf, sort)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Vector qualified as Vector
import System.Directory (doesDirectoryExist, listDirectory)
import System.Exit (ExitCode (..))
import System.FilePath ((</>))
import System.IO (hPutStrLn, stderr)
import System.Process (readProcessWithExitCode)

-- | A row's observed outcome on the ledger.
data Outcome
    = Accepted
    | Refused
    deriving stock (Int -> Outcome -> ShowS
[Outcome] -> ShowS
Outcome -> String
(Int -> Outcome -> ShowS)
-> (Outcome -> String) -> ([Outcome] -> ShowS) -> Show Outcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Outcome -> ShowS
showsPrec :: Int -> Outcome -> ShowS
$cshow :: Outcome -> String
show :: Outcome -> String
$cshowList :: [Outcome] -> ShowS
showList :: [Outcome] -> ShowS
Show, Outcome -> Outcome -> Bool
(Outcome -> Outcome -> Bool)
-> (Outcome -> Outcome -> Bool) -> Eq Outcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Outcome -> Outcome -> Bool
== :: Outcome -> Outcome -> Bool
$c/= :: Outcome -> Outcome -> Bool
/= :: Outcome -> Outcome -> Bool
Eq)

instance FromJSON Outcome where
    parseJSON :: Value -> Parser Outcome
parseJSON = String -> (Text -> Parser Outcome) -> Value -> Parser Outcome
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Outcome" ((Text -> Parser Outcome) -> Value -> Parser Outcome)
-> (Text -> Parser Outcome) -> Value -> Parser Outcome
forall a b. (a -> b) -> a -> b
$ \Text
t -> case Text
t of
        Text
"accepted" -> Outcome -> Parser Outcome
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Outcome
Accepted
        Text
"refused" -> Outcome -> Parser Outcome
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Outcome
Refused
        Text
_ -> String -> Parser Outcome
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unknown receipt outcome: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t)

instance ToJSON Outcome where
    toJSON :: Outcome -> Value
toJSON Outcome
Accepted = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"accepted" :: Text)
    toJSON Outcome
Refused = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"refused" :: Text)

{- | The refusal attribution for a refused row: the scripts that
refused — one role, or several @+@-joined roles in ledger-reported
order when a malformed transaction trips two validators at once —
and the node's phase-2 reason verbatim.
-}
data RefusalInfo = RefusalInfo
    { RefusalInfo -> Text
refusalScript :: !Text
    , RefusalInfo -> Text
refusalReason :: !Text
    , RefusalInfo -> Text
refusalPhase :: !Text
    -- ^ observed phase (phase-2 for script-execution failures)
    , RefusalInfo -> [Text]
refusalHashes :: ![Text]
    -- ^ extracted failure script hashes (structured attribution)
    , RefusalInfo -> Maybe Text
refusalBranch :: !(Maybe Text)
    {- ^ named validator branch, when the compiled trace exposes
    one; Nothing states explicitly that none is available (never
    infer a branch name from the intended property)
    -}
    , RefusalInfo -> Maybe Text
refusalLimit :: !(Maybe Text)
    -- ^ explicit attribution limit when no branch is available
    , RefusalInfo -> Maybe [ReplayEvidence]
refusalReplay :: !(Maybe [ReplayEvidence])
    {- ^ the traced replay of each failing purpose of the refused transaction
    (absent on receipts written before it)
    -}
    }
    deriving stock (Int -> RefusalInfo -> ShowS
[RefusalInfo] -> ShowS
RefusalInfo -> String
(Int -> RefusalInfo -> ShowS)
-> (RefusalInfo -> String)
-> ([RefusalInfo] -> ShowS)
-> Show RefusalInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefusalInfo -> ShowS
showsPrec :: Int -> RefusalInfo -> ShowS
$cshow :: RefusalInfo -> String
show :: RefusalInfo -> String
$cshowList :: [RefusalInfo] -> ShowS
showList :: [RefusalInfo] -> ShowS
Show, RefusalInfo -> RefusalInfo -> Bool
(RefusalInfo -> RefusalInfo -> Bool)
-> (RefusalInfo -> RefusalInfo -> Bool) -> Eq RefusalInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefusalInfo -> RefusalInfo -> Bool
== :: RefusalInfo -> RefusalInfo -> Bool
$c/= :: RefusalInfo -> RefusalInfo -> Bool
/= :: RefusalInfo -> RefusalInfo -> Bool
Eq)

instance FromJSON RefusalInfo where
    parseJSON :: Value -> Parser RefusalInfo
parseJSON = String
-> (Object -> Parser RefusalInfo) -> Value -> Parser RefusalInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RefusalInfo" ((Object -> Parser RefusalInfo) -> Value -> Parser RefusalInfo)
-> (Object -> Parser RefusalInfo) -> Value -> Parser RefusalInfo
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text
-> Text
-> Text
-> [Text]
-> Maybe Text
-> Maybe Text
-> Maybe [ReplayEvidence]
-> RefusalInfo
RefusalInfo
            (Text
 -> Text
 -> Text
 -> [Text]
 -> Maybe Text
 -> Maybe Text
 -> Maybe [ReplayEvidence]
 -> RefusalInfo)
-> Parser Text
-> Parser
     (Text
      -> Text
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe [ReplayEvidence]
      -> RefusalInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"script"
            Parser
  (Text
   -> Text
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe [ReplayEvidence]
   -> RefusalInfo)
-> Parser Text
-> Parser
     (Text
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe [ReplayEvidence]
      -> RefusalInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reason"
            Parser
  (Text
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe [ReplayEvidence]
   -> RefusalInfo)
-> Parser Text
-> Parser
     ([Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe [ReplayEvidence]
      -> RefusalInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"phase"
            Parser
  ([Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe [ReplayEvidence]
   -> RefusalInfo)
-> Parser [Text]
-> Parser
     (Maybe Text -> Maybe Text -> Maybe [ReplayEvidence] -> RefusalInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [Text]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hashes"
            Parser
  (Maybe Text -> Maybe Text -> Maybe [ReplayEvidence] -> RefusalInfo)
-> Parser (Maybe Text)
-> Parser (Maybe Text -> Maybe [ReplayEvidence] -> RefusalInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"branch"
            Parser (Maybe Text -> Maybe [ReplayEvidence] -> RefusalInfo)
-> Parser (Maybe Text)
-> Parser (Maybe [ReplayEvidence] -> RefusalInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"limit"
            Parser (Maybe [ReplayEvidence] -> RefusalInfo)
-> Parser (Maybe [ReplayEvidence]) -> Parser RefusalInfo
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [ReplayEvidence])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"replay"

instance ToJSON RefusalInfo where
    toJSON :: RefusalInfo -> Value
toJSON RefusalInfo
r =
        [Pair] -> Value
object
            [ Key
"script" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RefusalInfo -> Text
refusalScript RefusalInfo
r
            , Key
"reason" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RefusalInfo -> Text
refusalReason RefusalInfo
r
            , Key
"phase" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RefusalInfo -> Text
refusalPhase RefusalInfo
r
            , Key
"hashes" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RefusalInfo -> [Text]
refusalHashes RefusalInfo
r
            , Key
"branch" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RefusalInfo -> Maybe Text
refusalBranch RefusalInfo
r
            , Key
"limit" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RefusalInfo -> Maybe Text
refusalLimit RefusalInfo
r
            , Key
"replay" Key -> Maybe [ReplayEvidence] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RefusalInfo -> Maybe [ReplayEvidence]
refusalReplay RefusalInfo
r
            ]

{- | How a completed row stands against the behavioral models. The
chain outcome ('Outcome') is a fact; the verdict compares it with
what the models require. Q-002 (story 2, escalated to the user)
decides which model is the behavioral authority where Singular's
Lean and the consumer's theorems disagree; a row whose observation
contradicts the consumer's theorem while Singular's Lean permits
it is 'HeldQ002' — recorded, published, and never read as a pass:
the run exits non-zero while any row is held.
-}
data Verdict
    = {- | the observation is what the behavioral model requires (or
      the model constrains nothing here)
      -}
      AgreesWithModel
    | {- | Singular's Lean and the consumer's theorem disagree and
      the chain sided with Singular's Lean: held pending the user
      ruling (Q-002, story 2)
      -}
      HeldQ002
    | -- | the chain contradicts Singular's Lean itself
      DivergesFromLean
    | {- | a user ruling resolved the row's question; the observation
      is retained (as history or defect evidence) under the ruling,
      never read as a pass and never as conformance credit (A-001:
      historical-owner-change is resolved-by-ruling, not a fourth unresolved hold)
      -}
      ResolvedByRuling
    | {- | an unmet consumer requirement, kept by operator ruling
      2026-10-01 ("Keep as unmet requirement"): the consumer's
      theorem (cardano-keri @R9_reject_needs_rejectable@ at
      @0e638fad@, @RegistryGoals.lean@ blob @d38e81c0@) requires
      what the registry deliberately does not do
      (lambdasistemi/singular#320); alignment is
      lambdasistemi/cardano-keri#468. Also, by operator ruling 2026-10-02
      (narrowed #287), a row with no model counterpart: fold-against-superseded-root, surplus-fold-actions and wrong-redeemer-constructor-index,
      whose follow-ups are lambdasistemi/singular#346, #345 and #347.
      Recorded, published, never read as a pass: the run exits non-zero
      while any row is unmet.
      -}
      UnmetByRuling
    | {- | the row executed its available legs but named constructors
      stay unexercised, enumerated in 'receiptPartial' (E18 §3:
      explicit named residual, never green). A partial row is not
      fulfilled conformance: the session ends partial and the
      inventory overlay renders it partial, never executed.
      -}
      Partial
    deriving stock (Int -> Verdict -> ShowS
[Verdict] -> ShowS
Verdict -> String
(Int -> Verdict -> ShowS)
-> (Verdict -> String) -> ([Verdict] -> ShowS) -> Show Verdict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Verdict -> ShowS
showsPrec :: Int -> Verdict -> ShowS
$cshow :: Verdict -> String
show :: Verdict -> String
$cshowList :: [Verdict] -> ShowS
showList :: [Verdict] -> ShowS
Show, Verdict -> Verdict -> Bool
(Verdict -> Verdict -> Bool)
-> (Verdict -> Verdict -> Bool) -> Eq Verdict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Verdict -> Verdict -> Bool
== :: Verdict -> Verdict -> Bool
$c/= :: Verdict -> Verdict -> Bool
/= :: Verdict -> Verdict -> Bool
Eq, Int -> Verdict
Verdict -> Int
Verdict -> [Verdict]
Verdict -> Verdict
Verdict -> Verdict -> [Verdict]
Verdict -> Verdict -> Verdict -> [Verdict]
(Verdict -> Verdict)
-> (Verdict -> Verdict)
-> (Int -> Verdict)
-> (Verdict -> Int)
-> (Verdict -> [Verdict])
-> (Verdict -> Verdict -> [Verdict])
-> (Verdict -> Verdict -> [Verdict])
-> (Verdict -> Verdict -> Verdict -> [Verdict])
-> Enum Verdict
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 :: Verdict -> Verdict
succ :: Verdict -> Verdict
$cpred :: Verdict -> Verdict
pred :: Verdict -> Verdict
$ctoEnum :: Int -> Verdict
toEnum :: Int -> Verdict
$cfromEnum :: Verdict -> Int
fromEnum :: Verdict -> Int
$cenumFrom :: Verdict -> [Verdict]
enumFrom :: Verdict -> [Verdict]
$cenumFromThen :: Verdict -> Verdict -> [Verdict]
enumFromThen :: Verdict -> Verdict -> [Verdict]
$cenumFromTo :: Verdict -> Verdict -> [Verdict]
enumFromTo :: Verdict -> Verdict -> [Verdict]
$cenumFromThenTo :: Verdict -> Verdict -> Verdict -> [Verdict]
enumFromThenTo :: Verdict -> Verdict -> Verdict -> [Verdict]
Enum, Verdict
Verdict -> Verdict -> Bounded Verdict
forall a. a -> a -> Bounded a
$cminBound :: Verdict
minBound :: Verdict
$cmaxBound :: Verdict
maxBound :: Verdict
Bounded)

instance FromJSON Verdict where
    parseJSON :: Value -> Parser Verdict
parseJSON = String -> (Text -> Parser Verdict) -> Value -> Parser Verdict
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Verdict" ((Text -> Parser Verdict) -> Value -> Parser Verdict)
-> (Text -> Parser Verdict) -> Value -> Parser Verdict
forall a b. (a -> b) -> a -> b
$ \Text
t -> case Text
t of
        Text
"agrees-with-model" -> Verdict -> Parser Verdict
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verdict
AgreesWithModel
        Text
"held-q002" -> Verdict -> Parser Verdict
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verdict
HeldQ002
        Text
"diverges-from-lean" -> Verdict -> Parser Verdict
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verdict
DivergesFromLean
        Text
"resolved-by-ruling" -> Verdict -> Parser Verdict
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verdict
ResolvedByRuling
        Text
"unmet-by-ruling" -> Verdict -> Parser Verdict
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verdict
UnmetByRuling
        Text
"partial" -> Verdict -> Parser Verdict
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verdict
Partial
        Text
_ -> String -> Parser Verdict
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unknown receipt verdict: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t)

instance ToJSON Verdict where
    toJSON :: Verdict -> Value
toJSON Verdict
AgreesWithModel = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"agrees-with-model" :: Text)
    toJSON Verdict
HeldQ002 = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"held-q002" :: Text)
    toJSON Verdict
DivergesFromLean = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"diverges-from-lean" :: Text)
    toJSON Verdict
ResolvedByRuling = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"resolved-by-ruling" :: Text)
    toJSON Verdict
UnmetByRuling = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"unmet-by-ruling" :: Text)
    toJSON Verdict
Partial = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"partial" :: Text)

{- | Per-constructor standing inside a partial row's receipt (E18
§3/§4, NOTE-052): every constructor the row names is accounted —
exercised accepts with transaction evidence, named residuals with
reason and limit, pre-existing gaps with their gap evidence. No
general framework: the declared constructor set per row is fixed
below and the loader requires it exactly. StandingRefused exists
for E18's future refusal witnesses; this bounded schema admits
none — any refused entry fails closed (NOTE-055).
-}
data ConstructorStanding
    = StandingAccepted
    | StandingRefused
    | StandingResidual
    | StandingGap
    deriving stock (Int -> ConstructorStanding -> ShowS
[ConstructorStanding] -> ShowS
ConstructorStanding -> String
(Int -> ConstructorStanding -> ShowS)
-> (ConstructorStanding -> String)
-> ([ConstructorStanding] -> ShowS)
-> Show ConstructorStanding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstructorStanding -> ShowS
showsPrec :: Int -> ConstructorStanding -> ShowS
$cshow :: ConstructorStanding -> String
show :: ConstructorStanding -> String
$cshowList :: [ConstructorStanding] -> ShowS
showList :: [ConstructorStanding] -> ShowS
Show, ConstructorStanding -> ConstructorStanding -> Bool
(ConstructorStanding -> ConstructorStanding -> Bool)
-> (ConstructorStanding -> ConstructorStanding -> Bool)
-> Eq ConstructorStanding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstructorStanding -> ConstructorStanding -> Bool
== :: ConstructorStanding -> ConstructorStanding -> Bool
$c/= :: ConstructorStanding -> ConstructorStanding -> Bool
/= :: ConstructorStanding -> ConstructorStanding -> Bool
Eq)

instance FromJSON ConstructorStanding where
    parseJSON :: Value -> Parser ConstructorStanding
parseJSON = String
-> (Text -> Parser ConstructorStanding)
-> Value
-> Parser ConstructorStanding
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"ConstructorStanding" ((Text -> Parser ConstructorStanding)
 -> Value -> Parser ConstructorStanding)
-> (Text -> Parser ConstructorStanding)
-> Value
-> Parser ConstructorStanding
forall a b. (a -> b) -> a -> b
$ \Text
t -> case Text
t of
        Text
"accepted" -> ConstructorStanding -> Parser ConstructorStanding
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorStanding
StandingAccepted
        Text
"refused" -> ConstructorStanding -> Parser ConstructorStanding
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorStanding
StandingRefused
        Text
"residual" -> ConstructorStanding -> Parser ConstructorStanding
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorStanding
StandingResidual
        Text
"gap" -> ConstructorStanding -> Parser ConstructorStanding
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorStanding
StandingGap
        Text
_ -> String -> Parser ConstructorStanding
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unknown constructor standing: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t)

instance ToJSON ConstructorStanding where
    toJSON :: ConstructorStanding -> Value
toJSON ConstructorStanding
StandingAccepted = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"accepted" :: Text)
    toJSON ConstructorStanding
StandingRefused = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"refused" :: Text)
    toJSON ConstructorStanding
StandingResidual = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"residual" :: Text)
    toJSON ConstructorStanding
StandingGap = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"gap" :: Text)

data ConstructorEvidence = ConstructorEvidence
    { ConstructorEvidence -> Text
ceConstructor :: !Text
    , ConstructorEvidence -> Integer
ceIndex :: !Integer
    , ConstructorEvidence -> ConstructorStanding
ceStanding :: !ConstructorStanding
    , ConstructorEvidence -> Text
ceEvidence :: !Text
    }
    deriving stock (Int -> ConstructorEvidence -> ShowS
[ConstructorEvidence] -> ShowS
ConstructorEvidence -> String
(Int -> ConstructorEvidence -> ShowS)
-> (ConstructorEvidence -> String)
-> ([ConstructorEvidence] -> ShowS)
-> Show ConstructorEvidence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstructorEvidence -> ShowS
showsPrec :: Int -> ConstructorEvidence -> ShowS
$cshow :: ConstructorEvidence -> String
show :: ConstructorEvidence -> String
$cshowList :: [ConstructorEvidence] -> ShowS
showList :: [ConstructorEvidence] -> ShowS
Show, ConstructorEvidence -> ConstructorEvidence -> Bool
(ConstructorEvidence -> ConstructorEvidence -> Bool)
-> (ConstructorEvidence -> ConstructorEvidence -> Bool)
-> Eq ConstructorEvidence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstructorEvidence -> ConstructorEvidence -> Bool
== :: ConstructorEvidence -> ConstructorEvidence -> Bool
$c/= :: ConstructorEvidence -> ConstructorEvidence -> Bool
/= :: ConstructorEvidence -> ConstructorEvidence -> Bool
Eq)

instance FromJSON ConstructorEvidence where
    parseJSON :: Value -> Parser ConstructorEvidence
parseJSON = String
-> (Object -> Parser ConstructorEvidence)
-> Value
-> Parser ConstructorEvidence
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ConstructorEvidence" ((Object -> Parser ConstructorEvidence)
 -> Value -> Parser ConstructorEvidence)
-> (Object -> Parser ConstructorEvidence)
-> Value
-> Parser ConstructorEvidence
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text
-> Integer -> ConstructorStanding -> Text -> ConstructorEvidence
ConstructorEvidence
            (Text
 -> Integer -> ConstructorStanding -> Text -> ConstructorEvidence)
-> Parser Text
-> Parser
     (Integer -> ConstructorStanding -> Text -> ConstructorEvidence)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"constructor"
            Parser
  (Integer -> ConstructorStanding -> Text -> ConstructorEvidence)
-> Parser Integer
-> Parser (ConstructorStanding -> Text -> ConstructorEvidence)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"index"
            Parser (ConstructorStanding -> Text -> ConstructorEvidence)
-> Parser ConstructorStanding
-> Parser (Text -> ConstructorEvidence)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser ConstructorStanding
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"standing"
            Parser (Text -> ConstructorEvidence)
-> Parser Text -> Parser ConstructorEvidence
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"evidence"

instance ToJSON ConstructorEvidence where
    toJSON :: ConstructorEvidence -> Value
toJSON ConstructorEvidence
c =
        [Pair] -> Value
object
            [ Key
"constructor" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ConstructorEvidence -> Text
ceConstructor ConstructorEvidence
c
            , Key
"index" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ConstructorEvidence -> Integer
ceIndex ConstructorEvidence
c
            , Key
"standing" Key -> ConstructorStanding -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ConstructorEvidence -> ConstructorStanding
ceStanding ConstructorEvidence
c
            , Key
"evidence" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ConstructorEvidence -> Text
ceEvidence ConstructorEvidence
c
            ]

newtype PartialInfo = PartialInfo
    { PartialInfo -> [ConstructorEvidence]
partialConstructors :: [ConstructorEvidence]
    }
    deriving stock (Int -> PartialInfo -> ShowS
[PartialInfo] -> ShowS
PartialInfo -> String
(Int -> PartialInfo -> ShowS)
-> (PartialInfo -> String)
-> ([PartialInfo] -> ShowS)
-> Show PartialInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PartialInfo -> ShowS
showsPrec :: Int -> PartialInfo -> ShowS
$cshow :: PartialInfo -> String
show :: PartialInfo -> String
$cshowList :: [PartialInfo] -> ShowS
showList :: [PartialInfo] -> ShowS
Show, PartialInfo -> PartialInfo -> Bool
(PartialInfo -> PartialInfo -> Bool)
-> (PartialInfo -> PartialInfo -> Bool) -> Eq PartialInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PartialInfo -> PartialInfo -> Bool
== :: PartialInfo -> PartialInfo -> Bool
$c/= :: PartialInfo -> PartialInfo -> Bool
/= :: PartialInfo -> PartialInfo -> Bool
Eq)

instance FromJSON PartialInfo where
    parseJSON :: Value -> Parser PartialInfo
parseJSON = String
-> (Object -> Parser PartialInfo) -> Value -> Parser PartialInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PartialInfo" ((Object -> Parser PartialInfo) -> Value -> Parser PartialInfo)
-> (Object -> Parser PartialInfo) -> Value -> Parser PartialInfo
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        [ConstructorEvidence] -> PartialInfo
PartialInfo ([ConstructorEvidence] -> PartialInfo)
-> Parser [ConstructorEvidence] -> Parser PartialInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [ConstructorEvidence]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"constructors"

instance ToJSON PartialInfo where
    toJSON :: PartialInfo -> Value
toJSON PartialInfo
p =
        [Pair] -> Value
object [Key
"constructors" Key -> [ConstructorEvidence] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PartialInfo -> [ConstructorEvidence]
partialConstructors PartialInfo
p]

{- | The complete declared constructor set per partial-capable row
(constructor name, wire index). The loader requires EVERY receipt
for these rows to carry exactly this accounting: a receipt written
before the schema has no accounting and resolves unknown or
incomplete — never covered. Silence must not mean success.
Per-constructor data determines full/partial truth, not the
caller's verdict: green requires every entry accepted-or-refused;
any residual or gap forces partial.
-}
declaredConstructors :: Text -> Maybe [(Text, Integer)]
declaredConstructors :: Text -> Maybe [(Text, Integer)]
declaredConstructors Text
"update-redeemer-constructor-witnesses" =
    [(Text, Integer)] -> Maybe [(Text, Integer)]
forall a. a -> Maybe a
Just
        [ (Text
"Contribute", Integer
1)
        , (Text
"Modify", Integer
2)
        , (Text
"Retract", Integer
3)
        , (Text
"End", Integer
0)
        , (Text
"Sweep", Integer
4)
        ]
declaredConstructors Text
"request-and-mint-constructor-witnesses" =
    [(Text, Integer)] -> Maybe [(Text, Integer)]
forall a. a -> Maybe a
Just
        [ (Text
"Update", Integer
0)
        , (Text
"Rejected", Integer
1)
        , (Text
"Minting", Integer
0)
        , (Text
"Burning", Integer
2)
        , (Text
"Migrating", Integer
1)
        ]
declaredConstructors Text
_ = Maybe [(Text, Integer)]
forall a. Maybe a
Nothing

{- | Off-chain identity-derivation evidence (applied-validator-identity, E18 venue): the
deployed address derived through the PRODUCTION path against the
ACTUAL observed chain address, per validator by declared arity.
This is explicitly NOT phase-2 ledger evidence — the venue string
is fixed and loader-enforced so no later reader can mistake it.
-}
data DerivationOutcome
    = DerivMatch
    | DerivDistinct
    | DerivRefused
    deriving stock (Int -> DerivationOutcome -> ShowS
[DerivationOutcome] -> ShowS
DerivationOutcome -> String
(Int -> DerivationOutcome -> ShowS)
-> (DerivationOutcome -> String)
-> ([DerivationOutcome] -> ShowS)
-> Show DerivationOutcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DerivationOutcome -> ShowS
showsPrec :: Int -> DerivationOutcome -> ShowS
$cshow :: DerivationOutcome -> String
show :: DerivationOutcome -> String
$cshowList :: [DerivationOutcome] -> ShowS
showList :: [DerivationOutcome] -> ShowS
Show, DerivationOutcome -> DerivationOutcome -> Bool
(DerivationOutcome -> DerivationOutcome -> Bool)
-> (DerivationOutcome -> DerivationOutcome -> Bool)
-> Eq DerivationOutcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DerivationOutcome -> DerivationOutcome -> Bool
== :: DerivationOutcome -> DerivationOutcome -> Bool
$c/= :: DerivationOutcome -> DerivationOutcome -> Bool
/= :: DerivationOutcome -> DerivationOutcome -> Bool
Eq, Eq DerivationOutcome
Eq DerivationOutcome =>
(DerivationOutcome -> DerivationOutcome -> Ordering)
-> (DerivationOutcome -> DerivationOutcome -> Bool)
-> (DerivationOutcome -> DerivationOutcome -> Bool)
-> (DerivationOutcome -> DerivationOutcome -> Bool)
-> (DerivationOutcome -> DerivationOutcome -> Bool)
-> (DerivationOutcome -> DerivationOutcome -> DerivationOutcome)
-> (DerivationOutcome -> DerivationOutcome -> DerivationOutcome)
-> Ord DerivationOutcome
DerivationOutcome -> DerivationOutcome -> Bool
DerivationOutcome -> DerivationOutcome -> Ordering
DerivationOutcome -> DerivationOutcome -> DerivationOutcome
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 :: DerivationOutcome -> DerivationOutcome -> Ordering
compare :: DerivationOutcome -> DerivationOutcome -> Ordering
$c< :: DerivationOutcome -> DerivationOutcome -> Bool
< :: DerivationOutcome -> DerivationOutcome -> Bool
$c<= :: DerivationOutcome -> DerivationOutcome -> Bool
<= :: DerivationOutcome -> DerivationOutcome -> Bool
$c> :: DerivationOutcome -> DerivationOutcome -> Bool
> :: DerivationOutcome -> DerivationOutcome -> Bool
$c>= :: DerivationOutcome -> DerivationOutcome -> Bool
>= :: DerivationOutcome -> DerivationOutcome -> Bool
$cmax :: DerivationOutcome -> DerivationOutcome -> DerivationOutcome
max :: DerivationOutcome -> DerivationOutcome -> DerivationOutcome
$cmin :: DerivationOutcome -> DerivationOutcome -> DerivationOutcome
min :: DerivationOutcome -> DerivationOutcome -> DerivationOutcome
Ord)

instance FromJSON DerivationOutcome where
    parseJSON :: Value -> Parser DerivationOutcome
parseJSON = String
-> (Text -> Parser DerivationOutcome)
-> Value
-> Parser DerivationOutcome
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"DerivationOutcome" ((Text -> Parser DerivationOutcome)
 -> Value -> Parser DerivationOutcome)
-> (Text -> Parser DerivationOutcome)
-> Value
-> Parser DerivationOutcome
forall a b. (a -> b) -> a -> b
$ \Text
t -> case Text
t of
        Text
"match" -> DerivationOutcome -> Parser DerivationOutcome
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivationOutcome
DerivMatch
        Text
"distinct" -> DerivationOutcome -> Parser DerivationOutcome
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivationOutcome
DerivDistinct
        Text
"refused" -> DerivationOutcome -> Parser DerivationOutcome
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivationOutcome
DerivRefused
        Text
_ -> String -> Parser DerivationOutcome
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unknown derivation outcome: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t)

instance ToJSON DerivationOutcome where
    toJSON :: DerivationOutcome -> Value
toJSON DerivationOutcome
DerivMatch = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"match" :: Text)
    toJSON DerivationOutcome
DerivDistinct = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"distinct" :: Text)
    toJSON DerivationOutcome
DerivRefused = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"refused" :: Text)

data DerivationEvidence = DerivationEvidence
    { DerivationEvidence -> Text
deValidator :: !Text
    -- ^ e.g. state.state / request.request
    , DerivationEvidence -> Integer
deArity :: !Integer
    -- ^ declared parameter count (0 / 2)
    , DerivationEvidence -> Text
deComputed :: !Text
    -- ^ address derived through the production path
    , DerivationEvidence -> Text
deReference :: !Text
    {- ^ comparison side: the observed chain address for match and
    refused outcomes; the UNAPPLIED address for distinct outcomes
    (request arity 2) — labelled by the outcome, never conflated.
    -}
    , DerivationEvidence -> Text
deReferenceSource :: !Text
    {- ^ provenance of the reference side: chain-observed with the
    UTxO outref (match/refused outcomes) or pinned-unapplied
    (distinct outcomes). Loader-enforced per outcome.
    -}
    , DerivationEvidence -> DerivationOutcome
deOutcome :: !DerivationOutcome
    , DerivationEvidence -> Text
deVenue :: !Text
    -- ^ always derivationVenue (loader-enforced)
    }
    deriving stock (Int -> DerivationEvidence -> ShowS
[DerivationEvidence] -> ShowS
DerivationEvidence -> String
(Int -> DerivationEvidence -> ShowS)
-> (DerivationEvidence -> String)
-> ([DerivationEvidence] -> ShowS)
-> Show DerivationEvidence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DerivationEvidence -> ShowS
showsPrec :: Int -> DerivationEvidence -> ShowS
$cshow :: DerivationEvidence -> String
show :: DerivationEvidence -> String
$cshowList :: [DerivationEvidence] -> ShowS
showList :: [DerivationEvidence] -> ShowS
Show, DerivationEvidence -> DerivationEvidence -> Bool
(DerivationEvidence -> DerivationEvidence -> Bool)
-> (DerivationEvidence -> DerivationEvidence -> Bool)
-> Eq DerivationEvidence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DerivationEvidence -> DerivationEvidence -> Bool
== :: DerivationEvidence -> DerivationEvidence -> Bool
$c/= :: DerivationEvidence -> DerivationEvidence -> Bool
/= :: DerivationEvidence -> DerivationEvidence -> Bool
Eq)

instance FromJSON DerivationEvidence where
    parseJSON :: Value -> Parser DerivationEvidence
parseJSON = String
-> (Object -> Parser DerivationEvidence)
-> Value
-> Parser DerivationEvidence
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"DerivationEvidence" ((Object -> Parser DerivationEvidence)
 -> Value -> Parser DerivationEvidence)
-> (Object -> Parser DerivationEvidence)
-> Value
-> Parser DerivationEvidence
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text
-> Integer
-> Text
-> Text
-> Text
-> DerivationOutcome
-> Text
-> DerivationEvidence
DerivationEvidence
            (Text
 -> Integer
 -> Text
 -> Text
 -> Text
 -> DerivationOutcome
 -> Text
 -> DerivationEvidence)
-> Parser Text
-> Parser
     (Integer
      -> Text
      -> Text
      -> Text
      -> DerivationOutcome
      -> Text
      -> DerivationEvidence)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"validator"
            Parser
  (Integer
   -> Text
   -> Text
   -> Text
   -> DerivationOutcome
   -> Text
   -> DerivationEvidence)
-> Parser Integer
-> Parser
     (Text
      -> Text -> Text -> DerivationOutcome -> Text -> DerivationEvidence)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"arity"
            Parser
  (Text
   -> Text -> Text -> DerivationOutcome -> Text -> DerivationEvidence)
-> Parser Text
-> Parser
     (Text -> Text -> DerivationOutcome -> Text -> DerivationEvidence)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"computed"
            Parser
  (Text -> Text -> DerivationOutcome -> Text -> DerivationEvidence)
-> Parser Text
-> Parser (Text -> DerivationOutcome -> Text -> DerivationEvidence)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reference"
            Parser (Text -> DerivationOutcome -> Text -> DerivationEvidence)
-> Parser Text
-> Parser (DerivationOutcome -> Text -> DerivationEvidence)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"referenceSource" Parser (Maybe Text) -> Text -> Parser Text
forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
""
            Parser (DerivationOutcome -> Text -> DerivationEvidence)
-> Parser DerivationOutcome -> Parser (Text -> DerivationEvidence)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser DerivationOutcome
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"outcome"
            Parser (Text -> DerivationEvidence)
-> Parser Text -> Parser DerivationEvidence
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"venue"

instance ToJSON DerivationEvidence where
    toJSON :: DerivationEvidence -> Value
toJSON DerivationEvidence
d =
        [Pair] -> Value
object
            [ Key
"validator" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DerivationEvidence -> Text
deValidator DerivationEvidence
d
            , Key
"arity" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DerivationEvidence -> Integer
deArity DerivationEvidence
d
            , Key
"computed" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DerivationEvidence -> Text
deComputed DerivationEvidence
d
            , Key
"reference" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DerivationEvidence -> Text
deReference DerivationEvidence
d
            , Key
"referenceSource" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DerivationEvidence -> Text
deReferenceSource DerivationEvidence
d
            , Key
"outcome" Key -> DerivationOutcome -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DerivationEvidence -> DerivationOutcome
deOutcome DerivationEvidence
d
            , Key
"venue" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DerivationEvidence -> Text
deVenue DerivationEvidence
d
            ]

{- | The fixed venue string for derivation evidence. The loader
rejects any other venue: an identity check must not be readable
as ledger evidence.
-}
derivationVenue :: Text
derivationVenue :: Text
derivationVenue = Text
"off-chain-identity (not phase-2)"

{- | Evidence that a row executed. Accepted rows name the chain's
transaction ids and carry measurements; refused rows carry the
attribution and the submitted transaction's id under @rejected@
(empty @transactions@: nothing was accepted). @receiptVenue@
records where the refusal was observed: @node-submit@ (a node
ruling on a submitted transaction) or @ledger-eval@ (local ledger
evaluation only — never described as ledger execution).
@receiptDirty@ records whether the running tree had uncommitted
changes: a receipt from a dirty tree is honest working evidence,
but only a clean-tree receipt names a commit that reproduces it.
-}
data Receipt = Receipt
    { Receipt -> Text
receiptRow :: !Text
    , Receipt -> Outcome
receiptOutcome :: !Outcome
    , Receipt -> Verdict
receiptVerdict :: !Verdict
    , Receipt -> [Text]
receiptTransactions :: ![Text]
    , Receipt -> Maybe RefusalInfo
receiptRefusal :: !(Maybe RefusalInfo)
    , Receipt -> Maybe Integer
receiptMem :: !(Maybe Integer)
    , Receipt -> Maybe Integer
receiptCpu :: !(Maybe Integer)
    , Receipt -> Maybe Integer
receiptTxSize :: !(Maybe Integer)
    , Receipt -> Text
receiptBase :: !Text
    , Receipt -> Text
receiptNode :: !Text
    , Receipt -> Text
receiptBlueprint :: !Text
    , Receipt -> Text
receiptVenue :: !Text
    , Receipt -> Maybe Text
receiptRejected :: !(Maybe Text)
    , Receipt -> Bool
receiptDirty :: !Bool
    , Receipt -> Maybe PartialInfo
receiptPartial :: !(Maybe PartialInfo)
    {- ^ per-constructor accounting for partial rows (Nothing for
    every complete row; JSON-compatible: absent on old receipts).
    -}
    , Receipt -> Maybe [DerivationEvidence]
receiptDerivation :: !(Maybe [DerivationEvidence])
    {- ^ off-chain identity-derivation evidence (applied-validator-identity only; Nothing
    elsewhere; JSON-compatible).
    -}
    , Receipt -> Maybe [Value]
receiptSteps :: !(Maybe [Value])
    -- ^ generic live steps, each written after model and chain comparison.
    , Receipt -> Maybe ReplayCorrespondence
receiptReplayCorrespondence :: !(Maybe ReplayCorrespondence)
    {- ^ the traced build every replay reason in the receipt relies on (absent
    on receipts written before it)
    -}
    }
    deriving stock (Int -> Receipt -> ShowS
[Receipt] -> ShowS
Receipt -> String
(Int -> Receipt -> ShowS)
-> (Receipt -> String) -> ([Receipt] -> ShowS) -> Show Receipt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Receipt -> ShowS
showsPrec :: Int -> Receipt -> ShowS
$cshow :: Receipt -> String
show :: Receipt -> String
$cshowList :: [Receipt] -> ShowS
showList :: [Receipt] -> ShowS
Show, Receipt -> Receipt -> Bool
(Receipt -> Receipt -> Bool)
-> (Receipt -> Receipt -> Bool) -> Eq Receipt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Receipt -> Receipt -> Bool
== :: Receipt -> Receipt -> Bool
$c/= :: Receipt -> Receipt -> Bool
/= :: Receipt -> Receipt -> Bool
Eq)

instance FromJSON Receipt where
    parseJSON :: Value -> Parser Receipt
parseJSON = String -> (Object -> Parser Receipt) -> Value -> Parser Receipt
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Receipt" ((Object -> Parser Receipt) -> Value -> Parser Receipt)
-> (Object -> Parser Receipt) -> Value -> Parser Receipt
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text
-> Outcome
-> Verdict
-> [Text]
-> Maybe RefusalInfo
-> Maybe Integer
-> Maybe Integer
-> Maybe Integer
-> Text
-> Text
-> Text
-> Text
-> Maybe Text
-> Bool
-> Maybe PartialInfo
-> Maybe [DerivationEvidence]
-> Maybe [Value]
-> Maybe ReplayCorrespondence
-> Receipt
Receipt (Text
 -> Outcome
 -> Verdict
 -> [Text]
 -> Maybe RefusalInfo
 -> Maybe Integer
 -> Maybe Integer
 -> Maybe Integer
 -> Text
 -> Text
 -> Text
 -> Text
 -> Maybe Text
 -> Bool
 -> Maybe PartialInfo
 -> Maybe [DerivationEvidence]
 -> Maybe [Value]
 -> Maybe ReplayCorrespondence
 -> Receipt)
-> (Text -> Text)
-> Text
-> Outcome
-> Verdict
-> [Text]
-> Maybe RefusalInfo
-> Maybe Integer
-> Maybe Integer
-> Maybe Integer
-> Text
-> Text
-> Text
-> Text
-> Maybe Text
-> Bool
-> Maybe PartialInfo
-> Maybe [DerivationEvidence]
-> Maybe [Value]
-> Maybe ReplayCorrespondence
-> Receipt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
canonicalRowName
            (Text
 -> Outcome
 -> Verdict
 -> [Text]
 -> Maybe RefusalInfo
 -> Maybe Integer
 -> Maybe Integer
 -> Maybe Integer
 -> Text
 -> Text
 -> Text
 -> Text
 -> Maybe Text
 -> Bool
 -> Maybe PartialInfo
 -> Maybe [DerivationEvidence]
 -> Maybe [Value]
 -> Maybe ReplayCorrespondence
 -> Receipt)
-> Parser Text
-> Parser
     (Outcome
      -> Verdict
      -> [Text]
      -> Maybe RefusalInfo
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Text
      -> Text
      -> Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"row"
            Parser
  (Outcome
   -> Verdict
   -> [Text]
   -> Maybe RefusalInfo
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Text
   -> Text
   -> Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser Outcome
-> Parser
     (Verdict
      -> [Text]
      -> Maybe RefusalInfo
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Text
      -> Text
      -> Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Outcome
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"outcome"
            Parser
  (Verdict
   -> [Text]
   -> Maybe RefusalInfo
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Text
   -> Text
   -> Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser Verdict
-> Parser
     ([Text]
      -> Maybe RefusalInfo
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Text
      -> Text
      -> Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Verdict
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"verdict"
            Parser
  ([Text]
   -> Maybe RefusalInfo
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Text
   -> Text
   -> Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser [Text]
-> Parser
     (Maybe RefusalInfo
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Text
      -> Text
      -> Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [Text]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"transactions"
            Parser
  (Maybe RefusalInfo
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Text
   -> Text
   -> Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser (Maybe RefusalInfo)
-> Parser
     (Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Text
      -> Text
      -> Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe RefusalInfo)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"refusal"
            Parser
  (Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Text
   -> Text
   -> Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser (Maybe Integer)
-> Parser
     (Maybe Integer
      -> Maybe Integer
      -> Text
      -> Text
      -> Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"mem"
            Parser
  (Maybe Integer
   -> Maybe Integer
   -> Text
   -> Text
   -> Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser (Maybe Integer)
-> Parser
     (Maybe Integer
      -> Text
      -> Text
      -> Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"cpu"
            Parser
  (Maybe Integer
   -> Text
   -> Text
   -> Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser (Maybe Integer)
-> Parser
     (Text
      -> Text
      -> Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"txSize"
            Parser
  (Text
   -> Text
   -> Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser Text
-> Parser
     (Text
      -> Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"base"
            Parser
  (Text
   -> Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser Text
-> Parser
     (Text
      -> Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"node"
            Parser
  (Text
   -> Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser Text
-> Parser
     (Text
      -> Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"blueprint"
            Parser
  (Text
   -> Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser Text
-> Parser
     (Maybe Text
      -> Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"venue"
            Parser
  (Maybe Text
   -> Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Bool
      -> Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"rejected"
            Parser
  (Bool
   -> Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser Bool
-> Parser
     (Maybe PartialInfo
      -> Maybe [DerivationEvidence]
      -> Maybe [Value]
      -> Maybe ReplayCorrespondence
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"dirty"
            Parser
  (Maybe PartialInfo
   -> Maybe [DerivationEvidence]
   -> Maybe [Value]
   -> Maybe ReplayCorrespondence
   -> Receipt)
-> Parser (Maybe PartialInfo)
-> Parser
     (Maybe [DerivationEvidence]
      -> Maybe [Value] -> Maybe ReplayCorrespondence -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe PartialInfo)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"partial"
            Parser
  (Maybe [DerivationEvidence]
   -> Maybe [Value] -> Maybe ReplayCorrespondence -> Receipt)
-> Parser (Maybe [DerivationEvidence])
-> Parser (Maybe [Value] -> Maybe ReplayCorrespondence -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [DerivationEvidence])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"derivation"
            Parser (Maybe [Value] -> Maybe ReplayCorrespondence -> Receipt)
-> Parser (Maybe [Value])
-> Parser (Maybe ReplayCorrespondence -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [Value])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"steps"
            Parser (Maybe ReplayCorrespondence -> Receipt)
-> Parser (Maybe ReplayCorrespondence) -> Parser Receipt
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe ReplayCorrespondence)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"replayCorrespondence"

instance ToJSON Receipt where
    toJSON :: Receipt -> Value
toJSON Receipt
r =
        [Pair] -> Value
object
            [ Key
"row" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Text
receiptRow Receipt
r
            , Key
"outcome" Key -> Outcome -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Outcome
receiptOutcome Receipt
r
            , Key
"verdict" Key -> Verdict -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Verdict
receiptVerdict Receipt
r
            , Key
"transactions" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> [Text]
receiptTransactions Receipt
r
            , Key
"refusal" Key -> Maybe RefusalInfo -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe RefusalInfo
receiptRefusal Receipt
r
            , Key
"rejected" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe Text
receiptRejected Receipt
r
            , Key
"mem" Key -> Maybe Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe Integer
receiptMem Receipt
r
            , Key
"cpu" Key -> Maybe Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe Integer
receiptCpu Receipt
r
            , Key
"txSize" Key -> Maybe Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe Integer
receiptTxSize Receipt
r
            , Key
"base" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Text
receiptBase Receipt
r
            , Key
"dirty" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Bool
receiptDirty Receipt
r
            , Key
"node" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Text
receiptNode Receipt
r
            , Key
"blueprint" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Text
receiptBlueprint Receipt
r
            , Key
"venue" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Text
receiptVenue Receipt
r
            , Key
"partial" Key -> Maybe PartialInfo -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe PartialInfo
receiptPartial Receipt
r
            , Key
"derivation" Key -> Maybe [DerivationEvidence] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe [DerivationEvidence]
receiptDerivation Receipt
r
            , Key
"steps" Key -> Maybe [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe [Value]
receiptSteps Receipt
r
            , Key
"replayCorrespondence" Key -> Maybe ReplayCorrespondence -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe ReplayCorrespondence
receiptReplayCorrespondence Receipt
r
            ]

{- | Write one @receipt-<ROW>.json@ under the run's output directory.
Receipts over 'maxReceiptBytes' fail the run: a receipt nobody
can open is weak evidence, and a size convention would quietly
break on a later row.
-}
writeReceiptFile :: FilePath -> Receipt -> IO ()
writeReceiptFile :: String -> Receipt -> IO ()
writeReceiptFile String
dir Receipt
r = case Receipt -> Either String ()
checkReceiptSize Receipt
bounded of
    Left String
err -> ErrorCall -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> ErrorCall
ErrorCall String
err)
    Right () ->
        String -> ByteString -> IO ()
BSL.writeFile
            (String
dir String -> ShowS
</> (String
"receipt-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
bounded) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".json"))
            (Receipt -> ByteString
forall a. ToJSON a => a -> ByteString
encode Receipt
bounded)
  where
    bounded :: Receipt
bounded = Receipt
r{receiptSteps = fmap (map boundStepReason) (receiptSteps r)}
    boundStepReason :: Value -> Value
boundStepReason = Text -> (Value -> Value) -> Value -> Value
updateField Text
"chain" ((Value -> Value) -> Value -> Value)
-> (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> (Value -> Value) -> Value -> Value
updateField Text
"refusal" ((Value -> Value) -> Value -> Value)
-> (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> (Value -> Value) -> Value -> Value
updateField Text
"rejection" ((Value -> Value) -> Value -> Value)
-> (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ \case
        String Text
reason -> Text -> Value
String (Int -> Text -> Text
boundedNodeReason Int
maxLiveStepReasonChars Text
reason)
        Value
other -> Value
other
    updateField :: Text -> (Value -> Value) -> Value -> Value
updateField Text
name Value -> Value
f value :: Value
value@(Object Object
fields) =
        case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
Key.fromText Text
name) Object
fields of
            Just Value
existing -> Object -> Value
Object (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (Text -> Key
Key.fromText Text
name) (Value -> Value
f Value
existing) Object
fields)
            Maybe Value
Nothing -> Value
value
    updateField Text
_ Value -> Value
_ Value
value = Value
value

{- | Receipts stay readable: the insert-occupied-key refusal once embedded the whole
compiled validator (~30KB of base64) because @show@ on the
evaluation context prints every script and cost model.

The bound is measured (#287): the largest live receipt, reject-and-retract-refund-controls's, is 12 563
bytes, and 15 214 with the traced replay of each of its nine failing
purposes and the correspondence its reasons rely on; 18 432 leaves it a
fifth of headroom.
-}
maxReceiptBytes :: Int
maxReceiptBytes :: Int
maxReceiptBytes = Int
18432

-- | The tampers that alter the payment an exit owes, as a step record names them.
paymentTampers :: [Text]
paymentTampers :: [Text]
paymentTampers =
    (Tamper -> Text) -> [Tamper] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
        (String -> Text
T.pack (String -> Text) -> (Tamper -> String) -> Tamper -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tamper -> String
tamperName)
        [Tamper
OtherAddress, Tamper
ShortByOne, Tamper
OtherReference, Tamper
StateSpent]

{- | The tampers only a retraction has: its return bound to another request, and
a state input spent beside it, or a validity interval outside phase 2.
-}
retractionTampers :: [Text]
retractionTampers :: [Text]
retractionTampers =
    (Tamper -> Text) -> [Tamper] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
        (String -> Text
T.pack (String -> Text) -> (Tamper -> String) -> Tamper -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tamper -> String
tamperName)
        [Tamper
OtherReference, Tamper
StateSpent, Tamper
BeforePhase2, Tamper
AfterPhase2]

-- | The requests a retraction is admitted for on chain: insertions and reads.
retractableEdges :: [Text]
retractableEdges :: [Text]
retractableEdges =
    (Edge -> Text) -> [Edge] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Edge -> String) -> Edge -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> String
edgeName) [Edge
InsertAbsent, Edge
InsertActive, Edge
WitnessTerminal]

-- | Keep live node text readable inside each refusal step.
maxLiveStepReasonChars :: Int
maxLiveStepReasonChars :: Int
maxLiveStepReasonChars = Int
300

{- | A refused step's chain refusal with the replay of its failing purposes;
unchanged when the replay recorded none.
-}
stepReplay :: [ReplayEvidence] -> Value -> Value
stepReplay :: [ReplayEvidence] -> Value -> Value
stepReplay [] Value
refusal = Value
refusal
stepReplay [ReplayEvidence]
replay (Object Object
fields) =
    Object -> Value
Object (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
"replay" ([ReplayEvidence] -> Value
forall a. ToJSON a => a -> Value
toJSON [ReplayEvidence]
replay) Object
fields)
stepReplay [ReplayEvidence]
_ Value
refusal = Value
refusal

{- | The correspondence a story receipt carries: the session's, exactly when
one of its steps carries a replay.
-}
storyCorrespondence
    :: Maybe ReplayCorrespondence -> [Value] -> Maybe ReplayCorrespondence
storyCorrespondence :: Maybe ReplayCorrespondence -> [Value] -> Maybe ReplayCorrespondence
storyCorrespondence Maybe ReplayCorrespondence
correspondence [Value]
steps
    | (Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Value -> Bool
carriesReplay [Value]
steps = Maybe ReplayCorrespondence
correspondence
    | Bool
otherwise = Maybe ReplayCorrespondence
forall a. Maybe a
Nothing
  where
    carriesReplay :: Value -> Bool
carriesReplay Value
step = case Key -> Value -> Maybe Value
jsonField Key
"refusal" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
jsonField Key
"chain" Value
step of
        Just (Object Object
refusal) -> case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"replay" Object
refusal of
            Just (Array Array
entries) -> Bool -> Bool
not (Array -> Bool
forall a. Vector a -> Bool
Vector.null Array
entries)
            Maybe Value
_ -> Bool
False
        Maybe Value
_ -> Bool
False

{- | A receipt's replay evidence, complete and agreeing with what the receipt
claims: a step's @trace@ and an attribution's @branch@ are reasons a replay
admitted, so either needs the replay that admitted it.
-}
checkReplay :: FilePath -> Receipt -> Either String Receipt
checkReplay :: String -> Receipt -> Either String Receipt
checkReplay String
path Receipt
receipt = do
    steps <-
        ((Int, Value)
 -> Either String [(String, Maybe Text, Maybe [ReplayEvidence])])
-> [(Int, Value)]
-> Either String [[(String, Maybe Text, Maybe [ReplayEvidence])]]
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
            (Int, Value)
-> Either String [(String, Maybe Text, Maybe [ReplayEvidence])]
forall {a} {a}.
(FromJSON a, Show a) =>
(a, Value) -> Either String [(String, Maybe Text, Maybe a)]
stepClaim
            ([Int] -> [Value] -> [(Int, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ([Value] -> Maybe [Value] -> [Value]
forall a. a -> Maybe a -> a
fromMaybe [] (Receipt -> Maybe [Value]
receiptSteps Receipt
receipt)))
    let attribution =
            [ (String
"refusal", RefusalInfo -> Maybe Text
refusalBranch RefusalInfo
info, RefusalInfo -> Maybe [ReplayEvidence]
refusalReplay RefusalInfo
info)
            | Just RefusalInfo
info <- [Receipt -> Maybe RefusalInfo
receiptRefusal Receipt
receipt]
            ]
        claims = [[(String, Maybe Text, Maybe [ReplayEvidence])]]
-> [(String, Maybe Text, Maybe [ReplayEvidence])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(String, Maybe Text, Maybe [ReplayEvidence])]]
steps [(String, Maybe Text, Maybe [ReplayEvidence])]
-> [(String, Maybe Text, Maybe [ReplayEvidence])]
-> [(String, Maybe Text, Maybe [ReplayEvidence])]
forall a. Semigroup a => a -> a -> a
<> [(String, Maybe Text, Maybe [ReplayEvidence])]
attribution
    mapM_
        ( \(String
place, Maybe Text
claim, Maybe [ReplayEvidence]
replay) ->
            (String -> Either String ())
-> (() -> Either String ()) -> Either String () -> Either String ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                (\String
problem -> String -> Either String ()
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
place String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
problem))
                () -> Either String ()
forall a b. b -> Either a b
Right
                (Maybe Text -> Maybe [ReplayEvidence] -> Either String ()
replayProblem Maybe Text
claim Maybe [ReplayEvidence]
replay)
        )
        claims
    let reasons =
            [ Text
reason
            | (String
_, Maybe Text
_, Just [ReplayEvidence]
entries) <- [(String, Maybe Text, Maybe [ReplayEvidence])]
claims
            , ReplayEvidence
entry <- [ReplayEvidence]
entries
            , Just Text
reason <- [ReplayEvidence -> Maybe Text
replayReason ReplayEvidence
entry]
            ]
    case (reasons, receiptReplayCorrespondence receipt) of
        ([], Maybe ReplayCorrespondence
_) -> Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
receipt
        ([Text]
_, Just ReplayCorrespondence
c)
            | Bool -> Bool
not
                ( (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
                    Text -> Bool
T.null
                    [ ReplayCorrespondence -> Text
correspondenceSource ReplayCorrespondence
c
                    , ReplayCorrespondence -> Text
correspondenceCompiler ReplayCorrespondence
c
                    , ReplayCorrespondence -> Text
correspondenceFlags ReplayCorrespondence
c
                    , ReplayCorrespondence -> Text
correspondenceDigest ReplayCorrespondence
c
                    ]
                ) ->
                Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
receipt
        ([Text], Maybe ReplayCorrespondence)
_ ->
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": replay reasons without the traced build they rely on")
  where
    stepClaim :: (a, Value) -> Either String [(String, Maybe Text, Maybe a)]
stepClaim (a
i, Value
step) = case Key -> Value -> Maybe Value
jsonField Key
"refusal" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
jsonField Key
"chain" Value
step of
        Just (Object Object
refusal) -> do
            replay <- case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"replay" Object
refusal of
                Maybe Value
Nothing -> Maybe a -> Either String (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
                Just Value
Null -> Maybe a -> Either String (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
                Just Value
value -> case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
value of
                    Success a
entries -> Maybe a -> Either String (Maybe a)
forall a b. b -> Either a b
Right (a -> Maybe a
forall a. a -> Maybe a
Just a
entries)
                    Error String
err ->
                        String -> Either String (Maybe a)
forall a b. a -> Either a b
Left
                            (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": step " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": unreadable replay: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err)
            let claim = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"trace" Object
refusal of
                    Just (String Text
reason) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
reason
                    Maybe Value
_ -> Maybe Text
forall a. Maybe a
Nothing
            Right [("step " <> show i, claim, replay)]
        Maybe Value
_ -> [(String, Maybe Text, Maybe a)]
-> Either String [(String, Maybe Text, Maybe a)]
forall a b. b -> Either a b
Right []

{- | What is wrong with one refusal's replay against the reason the receipt
claims for it, if anything.
-}
replayProblem
    :: Maybe Text -> Maybe [ReplayEvidence] -> Either String ()
replayProblem :: Maybe Text -> Maybe [ReplayEvidence] -> Either String ()
replayProblem Maybe Text
claim = \case
    Maybe [ReplayEvidence]
Nothing -> case Maybe Text
claim of
        Just Text
reason ->
            String -> Either String ()
forall a b. a -> Either a b
Left
                ( String
"claims the traced reason "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
reason
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" without the replay that admitted it"
                )
        Maybe Text
Nothing -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    Just [] -> String -> Either String ()
forall a b. a -> Either a b
Left String
"replay names no failing purpose"
    Just [ReplayEvidence]
entries -> do
        (ReplayEvidence -> Either String ())
-> [ReplayEvidence] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ReplayEvidence -> Either String ()
entryProblem [ReplayEvidence]
entries
        case Maybe Text
claim of
            Just Text
reason
                | Text
reason Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
r | ReplayEvidence
e <- [ReplayEvidence]
entries, Just Text
r <- [ReplayEvidence -> Maybe Text
replayReason ReplayEvidence
e]] ->
                    String -> Either String ()
forall a b. a -> Either a b
Left
                        (String
"claims " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
reason String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", a reason the replay did not admit")
            Maybe Text
_ -> () -> Either String ()
forall a b. b -> Either a b
Right ()
  where
    entryProblem :: ReplayEvidence -> Either String ()
entryProblem ReplayEvidence
e
        | Text -> Bool
T.null (ReplayEvidence -> Text
replayDeployedHash ReplayEvidence
e) =
            String -> Either String ()
forall a b. a -> Either a b
Left String
"replay names a purpose without its deployed hash"
        | Bool
otherwise = case (ReplayEvidence -> Maybe Text
replayReason ReplayEvidence
e, ReplayEvidence -> Maybe Text
replayCause ReplayEvidence
e) of
            (Just Text
_, Just Text
_) -> String -> Either String ()
forall a b. a -> Either a b
Left String
"replay names both a reason and a cause"
            (Maybe Text
Nothing, Maybe Text
Nothing) -> String -> Either String ()
forall a b. a -> Either a b
Left String
"replay names neither a reason nor a cause"
            (Just Text
reason, Maybe Text
Nothing)
                | Text -> Bool
T.null Text
reason -> String -> Either String ()
forall a b. a -> Either a b
Left String
"replay names an empty reason"
                | Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Text -> Bool
T.null (ReplayEvidence -> Maybe Text
replayTracedHash ReplayEvidence
e) ->
                    String -> Either String ()
forall a b. a -> Either a b
Left String
"replay names a reason without its traced hash"
                | Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Text -> Bool
T.null (ReplayEvidence -> Maybe Text
replayCaptureId ReplayEvidence
e) ->
                    String -> Either String ()
forall a b. a -> Either a b
Left String
"replay names a reason without the capture it was replayed from"
                | Bool
otherwise -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            (Maybe Text
Nothing, Just Text
cause)
                | Text
cause Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (UnobservedCause -> Text) -> [UnobservedCause] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map UnobservedCause -> Text
causeName [UnobservedCause
forall a. Bounded a => a
minBound .. UnobservedCause
forall a. Bounded a => a
maxBound] -> () -> Either String ()
forall a b. b -> Either a b
Right ()
                | Bool
otherwise -> String -> Either String ()
forall a b. a -> Either a b
Left (String
"replay names an unknown cause " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
cause)

jsonField :: Key.Key -> Value -> Maybe Value
jsonField :: Key -> Value -> Maybe Value
jsonField Key
name = \case
    Object Object
fields -> Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
name Object
fields
    Value
_ -> Maybe Value
forall a. Maybe a
Nothing

{- | Validate the generic evidence body independently of the runner. The
runner computes its values; the loader refuses missing comparisons and
fabricated agreement shapes before a book can count the receipt.
-}
stepsComplete
    :: FilePath -> Receipt -> [Value] -> Either String Receipt
stepsComplete :: String -> Receipt -> [Value] -> Either String Receipt
stepsComplete String
path Receipt
receipt [Value]
steps
    | [Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
steps = String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": live receipt has no steps")
    | Bool
otherwise = do
        (Value -> Either String ()) -> [Value] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Value -> Either String ()
checkStep [Value]
steps
        let landed :: [Text]
landed =
                [ Text
txid
                | Value
step <- [Value]
steps
                , Just (String Text
"accepted") <- [Key -> Value -> Maybe Value
at Key
"outcome" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"chain" Value
step]
                , Just (String Text
txid) <- [Key -> Value -> Maybe Value
at Key
"txid" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"chain" Value
step]
                ]
        if [Text]
landed [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== Receipt -> [Text]
receiptTransactions Receipt
receipt
            then Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
receipt
            else
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted step transactions differ from the receipt envelope"
                    )
  where
    at :: Key -> Value -> Maybe Value
at Key
name (Object Object
fields) = Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
name Object
fields
    at Key
_ Value
_ = Maybe Value
forall a. Maybe a
Nothing
    failure :: String -> Either String b
failure String
reason = String -> Either String b
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": invalid live step: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
reason)
    checkStep :: Value -> Either String ()
checkStep Value
step = case Key -> Value -> Maybe Value
at Key
"batch" Value
step of
        Just Value
_ -> String -> Value -> Either String ()
batchRecordProblem String
path Value
step
        Maybe Value
Nothing -> Value -> Either String ()
checkEdgeStep Value
step
    checkEdgeStep :: Value -> Either String ()
checkEdgeStep Value
step = do
        edge <- case (Key -> Value -> Maybe Value
at Key
"registry" Value
step, Key -> Value -> Maybe Value
at Key
"edge" Value
step, Key -> Value -> Maybe Value
at Key
"request" Value
step) of
            (Just (Number Scientific
_), Just (String Text
edge), Just (Object Object
_))
                | Text
edge Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Edge -> Text) -> [Edge] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Edge -> String) -> Edge -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> String
edgeName) [Edge
forall a. Bounded a => a
minBound .. Edge
forall a. Bounded a => a
maxBound] ->
                    Text -> Either String Text
forall a b. b -> Either a b
Right Text
edge
            (Maybe Value, Maybe Value, Maybe Value)
_ -> String -> Either String Text
forall {b}. String -> Either String b
failure String
"missing registry, edge or model request"
        -- A step names the exit its request left by; a receipt written before
        -- steps carried the field records folds only.
        exit <- case at "exit" step of
            Maybe Value
Nothing -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
edge
            Just (String Text
name)
                | Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"reject", Text
"retract"] -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
name
                | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
edge -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
name
                | Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Edge -> Text) -> [Edge] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Edge -> String) -> Edge -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> String
edgeName) [Edge
forall a. Bounded a => a
minBound .. Edge
forall a. Bounded a => a
maxBound] ->
                    String -> Either String Text
forall {b}. String -> Either String b
failure String
"a fold exit names another edge than its request"
            Maybe Value
_ -> String -> Either String Text
forall {b}. String -> Either String b
failure String
"unknown exit"
        let tamper = Key -> Value -> Maybe Value
at Key
"tamper" Value
step
            model = Key -> Value -> Maybe Value
at Key
"outcome" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"model" Value
step
            chain = Key -> Value -> Maybe Value
at Key
"outcome" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"chain" Value
step
            comparison = Key -> Value -> Maybe Value
at Key
"comparison" Value
step
            -- Where the comparison found the observation to differ. A receipt
            -- written before steps carried the field reports none.
            differences = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (Array -> Value
Array Array
forall a. Vector a
Vector.empty) (Key -> Value -> Maybe Value
at Key
"differences" Value
step)
            signerDifference =
                Array -> Value
Array
                    ( Value -> Array
forall a. a -> Vector a
Vector.singleton
                        ( Object -> Value
Object
                            ( [Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList
                                [(Key
"observation", Text -> Value
String Text
"tx"), (Key
"path", Text -> Value
String Text
"signers")]
                            )
                        )
                    )
            admissionReason
                | Text
exit Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"retract"
                , Text
edge Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
retractableEdges =
                    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"withdraw-insert-only"
                | Maybe Value
tamper Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
"unsigned") = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"retract-owner"
                | Maybe Value
tamper
                    Maybe Value -> [Maybe Value] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Tamper -> Maybe Value) -> [Tamper] -> [Maybe Value]
forall a b. (a -> b) -> [a] -> [b]
map (Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> (Tamper -> Value) -> Tamper -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String (Text -> Value) -> (Tamper -> Text) -> Tamper -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Tamper -> String) -> Tamper -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tamper -> String
tamperName) [Tamper
BeforePhase2, Tamper
AfterPhase2] =
                    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"not-phase2"
                | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
        case admissionReason of
            Maybe Text
Nothing -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            Just Text
reason -> do
                if Text
exit Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"retract"
                    Bool -> Bool -> Bool
&& Maybe Value
model Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
"refused")
                    Bool -> Bool -> Bool
&& Maybe Value
chain Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
"refused")
                    Bool -> Bool -> Bool
&& (Key -> Value -> Maybe Value
at Key
"reason" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"model" Value
step) Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
reason)
                    then () -> Either String ()
forall a b. b -> Either a b
Right ()
                    else
                        String -> Either String ()
forall {b}. String -> Either String b
failure
                            String
"retraction admission refusal has the wrong exit, outcome or model reason"
                case (Key -> Value -> Maybe Value
at Key
"requestScript" Value
step, Key -> Value -> Maybe Value
at Key
"refusal" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"chain" Value
step) of
                    (Just (String Text
marker), Just Value
refusal)
                        | Bool -> Bool
not (Text -> Bool
T.null Text
marker)
                        , Just (Array Array
hashes) <- Key -> Value -> Maybe Value
at Key
"hashes" Value
refusal
                        , Text -> Value
String Text
marker Value -> Array -> Bool
forall a. Eq a => a -> Vector a -> Bool
`Vector.elem` Array
hashes
                        , Just (Array Array
scripts) <- Key -> Value -> Maybe Value
at Key
"scripts" Value
refusal
                        , Text -> Value
String Text
"request" Value -> Array -> Bool
forall a. Eq a => a -> Vector a -> Bool
`Vector.elem` Array
scripts ->
                            () -> Either String ()
forall a b. b -> Either a b
Right ()
                    (Maybe Value, Maybe Value)
_ ->
                        String -> Either String ()
forall {b}. String -> Either String b
failure
                            String
"retraction admission refusal lacks request-script attribution"
        case (model, chain, comparison) of
            (Just (String Text
m), Just (String Text
c), Just (String Text
verdict))
                | Text
m Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"accepted", Text
"refused", Text
"unsupported"]
                , Text
c Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"accepted", Text
"refused", Text
"unsupported"]
                , Text
verdict Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"agrees", Text
"disagrees", Text
"unsupported"] ->
                    () -> Either String ()
forall a b. b -> Either a b
Right ()
            (Maybe Value, Maybe Value, Maybe Value)
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"missing or unknown model, chain or comparison outcome"
        case chain of
            Just (String Text
"unsupported") -> case Key -> Value -> Maybe Value
at Key
"reason" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"chain" Value
step of
                Just (String Text
reason) | Bool -> Bool
not (Text -> Bool
T.null Text
reason) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
                Maybe Value
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"unsupported chain outcome has no observed reason"
            Just (String Text
"refused") -> case Key -> Value -> Maybe Value
at Key
"refusal" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"chain" Value
step of
                Just (Object Object
refusal) -> case Object -> Either String ()
forall {a}. IsString a => Object -> Either a ()
refusalComplete Object
refusal of
                    Right () -> () -> Either String ()
forall a b. b -> Either a b
Right ()
                    Left String
reason -> String -> Either String ()
forall {b}. String -> Either String b
failure String
reason
                Maybe Value
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"refused live step has no node refusal details"
            Maybe Value
_ -> () -> Either String ()
forall a b. b -> Either a b
Right ()
        case (tamper, comparison, model, chain) of
            (Just Value
Null, Just (String Text
"agrees"), Maybe Value
m, Maybe Value
c)
                | Maybe Value
m Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Value
c -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"untampered agreement changes the outcome class"
                | Value
differences Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Array -> Value
Array Array
forall a. Vector a
Vector.empty ->
                    String -> Either String ()
forall {b}. String -> Either String b
failure String
"untampered agreement reports differences"
                | Bool
otherwise -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            (Just (String Text
name), Maybe Value
_, Maybe Value
_, Maybe Value
_)
                | Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
retractionTampers
                , Text
exit Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"retract" ->
                    String -> Either String ()
forall {b}. String -> Either String b
failure
                        String
"only a retraction is bound to its request or refused for what it spends"
            -- A payment sent elsewhere or short is refused by both sides: the
            -- ledger by an attributed script, the model for the reason its
            -- judgement names.
            ( Just (String Text
name)
                , Just (String Text
"agrees")
                , Just (String Text
"refused")
                , Just (String Text
"refused")
                )
                    | Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
paymentTampers -> do
                        case Key -> Value -> Maybe Value
at Key
"hashes" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Key -> Value -> Maybe Value
at Key
"refusal" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"chain" Value
step) of
                            Just (Array Array
hashes) | Bool -> Bool
not (Array -> Bool
forall a. Vector a -> Bool
Vector.null Array
hashes) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
                            Maybe Value
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"tamper refusal has no attributed script hashes"
                        case Key -> Value -> Maybe Value
at Key
"reason" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
at Key
"model" Value
step of
                            Just (String Text
why) | Bool -> Bool
not (Text -> Bool
T.null Text
why) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
                            Maybe Value
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"payment tamper refusal names no model reason"
            (Just (String Text
name), Just (String Text
"agrees"), Maybe Value
_, Maybe Value
_)
                | Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
paymentTampers ->
                    String -> Either String ()
forall {b}. String -> Either String b
failure
                        String
"payment tamper agreement does not have model and chain refusal"
            -- An extra required signer is accepted by the ledger; its agreement
            -- is the comparison reporting exactly that signer difference.
            ( Just (String Text
"extra-signer")
                , Just (String Text
"agrees")
                , Just (String Text
"accepted")
                , Just (String Text
"accepted")
                )
                    | Value
differences Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
signerDifference -> () -> Either String ()
forall a b. b -> Either a b
Right ()
                    | Bool
otherwise ->
                        String -> Either String ()
forall {b}. String -> Either String b
failure
                            String
"extra-signer agreement does not report exactly the signer difference"
            (Just (String Text
"extra-signer"), Just (String Text
"agrees"), Maybe Value
_, Maybe Value
_) ->
                String -> Either String ()
forall {b}. String -> Either String b
failure
                    String
"extra-signer agreement does not have model and chain acceptance"
            (Just Value
Null, Maybe Value
_, Maybe Value
_, Maybe Value
_) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            (Just (String Text
name), Maybe Value
_, Maybe Value
_, Maybe Value
_) | Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
paymentTampers -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            (Just (String Text
"extra-signer"), Maybe Value
_, Maybe Value
_, Maybe Value
_) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            (Just (String Text
name), Maybe Value
_, Maybe Value
_, Maybe Value
_)
                | Text
name
                    Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Tamper -> Text) -> [Tamper] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Tamper -> String) -> Tamper -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tamper -> String
tamperName) [Tamper
Unsigned, Tamper
BeforePhase2, Tamper
AfterPhase2] ->
                    () -> Either String ()
forall a b. b -> Either a b
Right ()
            (Maybe Value, Maybe Value, Maybe Value, Maybe Value)
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"unknown tamper"
        case (at "compared" step, at "unobserved" step) of
            (Just (Array Array
names), Just (Array Array
_))
                | Maybe Value
comparison Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
"agrees")
                , Maybe Value
model Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
"accepted")
                , Maybe Value
chain Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
"accepted")
                , Array -> Int
forall a. Vector a -> Int
Vector.length Array
names Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9 ->
                    () -> Either String ()
forall a b. b -> Either a b
Right ()
                | Array -> Bool
forall a. Vector a -> Bool
Vector.null Array
names -> () -> Either String ()
forall a b. b -> Either a b
Right ()
                | Bool
otherwise ->
                    String -> Either String ()
forall {b}. String -> Either String b
failure
                        String
"accepted agreement does not account for all nine observations"
            (Maybe Value, Maybe Value)
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"missing compared or unobserved arrays"
        case (tamper, model, chain, comparison, at "perturbation" step) of
            ( Just Value
Null
                , Just (String Text
"accepted")
                , Just (String Text
"accepted")
                , Just (String Text
"agrees")
                , Just (Object Object
evidence)
                )
                    | Just (Number Scientific
count) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"refused" Object
evidence
                    , Scientific
count Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
> Scientific
0
                    , Just (Object Object
_) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"byObservation" Object
evidence
                    , Just (Array Array
_) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"exempt" Object
evidence ->
                        () -> Either String ()
forall a b. b -> Either a b
Right ()
            ( Just Value
Null
                , Just (String Text
"accepted")
                , Just (String Text
"accepted")
                , Just (String Text
"agrees")
                , Maybe Value
_
                ) -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"accepted agreement has no perturbation evidence"
            (Maybe Value
_, Maybe Value
_, Maybe Value
_, Maybe Value
_, Just Value
Null) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            (Maybe Value, Maybe Value, Maybe Value, Maybe Value, Maybe Value)
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"unexpected perturbation evidence"
    refusalComplete :: Object -> Either a ()
refusalComplete Object
refusal = case ( Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"rejection" Object
refusal
                                   , Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"measured" Object
refusal
                                   , Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"declared" Object
refusal
                                   , Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"budgetPurposes" Object
refusal
                                   , Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"kind" Object
refusal
                                   ) of
        ( Just (String Text
reason)
            , Just (Object Object
measured)
            , Just (Object Object
declared)
            , Just (Array Array
budgetNames)
            , Just (String Text
kind)
            )
                | Text -> Bool
T.null Text
reason -> a -> Either a ()
forall a b. a -> Either a b
Left a
"refusal has an empty node reason"
                | Text -> Int
T.length Text
reason Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLiveStepReasonChars ->
                    a -> Either a ()
forall a b. a -> Either a b
Left a
"refusal node reason exceeds its bound"
                | [Pair] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
measured) ->
                    a -> Either a ()
forall a b. a -> Either a b
Left a
"refusal has no per-purpose measurements"
                | Bool -> Bool
not ((Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Value -> Bool
validMeasurement (Object -> [Value]
forall v. KeyMap v -> [v]
KM.elems Object
measured)) ->
                    a -> Either a ()
forall a b. a -> Either a b
Left a
"refusal has an invalid per-purpose measurement"
                | Bool -> Bool
not ((Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Value -> Bool
validDeclaredUnits (Object -> [Value]
forall v. KeyMap v -> [v]
KM.elems Object
declared)) ->
                    a -> Either a ()
forall a b. a -> Either a b
Left a
"refusal has invalid per-purpose declarations"
                | [Key] -> [Key]
forall a. Ord a => [a] -> [a]
sort (Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
measured) [Key] -> [Key] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Key] -> [Key]
forall a. Ord a => [a] -> [a]
sort (Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
declared) ->
                    a -> Either a ()
forall a b. a -> Either a b
Left a
"refusal measurements and declarations name different purposes"
                | Bool
otherwise -> do
                    names <- (Value -> Either a Key) -> [Value] -> Either a [Key]
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 Value -> Either a Key
forall {a}. IsString a => Value -> Either a Key
budgetName (Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
budgetNames)
                    let actual = [Key] -> [Key]
forall a. Ord a => [a] -> [a]
sort [Key]
names
                        expectedKind = if [Key] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
actual then Text
"validator" else Text
"budget"
                    if any (`notElem` KM.keys measured) actual
                        then Left "budget refusal names an unmeasured purpose"
                        else
                            if not (all (validSource measured) (KM.toList declared))
                                then Left "failed evaluation is not marked probe-allowance"
                                else
                                    if kind /= expectedKind
                                        then
                                            Left "refusal kind does not match its per-purpose unit comparisons"
                                        else Right ()
        (Maybe Value, Maybe Value, Maybe Value, Maybe Value, Maybe Value)
_ ->
            a -> Either a ()
forall a b. a -> Either a b
Left
                a
"refused live step lacks bounded reason, per-purpose measurements, declarations or budget names"
    budgetName :: Value -> Either a Key
budgetName (String Text
name)
        | Bool -> Bool
not (Text -> Bool
T.null Text
name) = Key -> Either a Key
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
name)
    budgetName Value
_ = a -> Either a Key
forall a b. a -> Either a b
Left a
"budget refusal names an invalid script purpose"
    validMeasurement :: Value -> Bool
validMeasurement (Object Object
fields) =
        Maybe (Scientific, Scientific) -> Bool
forall a. Maybe a -> Bool
isJust (Value -> Maybe (Scientific, Scientific)
unitPair (Object -> Value
Object Object
fields))
            Bool -> Bool -> Bool
|| case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"error" Object
fields of
                Just (String Text
message) -> Bool -> Bool
not (Text -> Bool
T.null Text
message)
                Maybe Value
_ -> Bool
False
    validMeasurement Value
_ = Bool
False
    validDeclaredUnits :: Value -> Bool
validDeclaredUnits Value
value = Maybe (Scientific, Scientific) -> Bool
forall a. Maybe a -> Bool
isJust (Value -> Maybe (Scientific, Scientific)
unitPair Value
value)
    validSource :: Object -> Pair -> Bool
validSource Object
measured (Key
purpose, Object Object
declaration) = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
purpose Object
measured of
        Just (Object Object
result)
            | Key -> Object -> Bool
forall a. Key -> KeyMap a -> Bool
KM.member Key
"error" Object
result ->
                Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"source" Object
declaration Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
"probe-allowance")
        Maybe Value
_ -> Bool
True
    validSource Object
_ Pair
_ = Bool
False
    unitPair :: Value -> Maybe (Scientific, Scientific)
unitPair (Object Object
fields) = case (Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"mem" Object
fields, Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"cpu" Object
fields) of
        (Just (Number Scientific
mem), Just (Number Scientific
cpu)) -> (Scientific, Scientific) -> Maybe (Scientific, Scientific)
forall a. a -> Maybe a
Just (Scientific
mem, Scientific
cpu)
        (Maybe Value, Maybe Value)
_ -> Maybe (Scientific, Scientific)
forall a. Maybe a
Nothing
    unitPair Value
_ = Maybe (Scientific, Scientific)
forall a. Maybe a
Nothing

{- | The size bound, purely: oversized receipts are an error naming
the row and the byte count.
-}
checkReceiptSize :: Receipt -> Either String ()
checkReceiptSize :: Receipt -> Either String ()
checkReceiptSize Receipt
r
    | ByteString -> Int64
BSL.length (Receipt -> ByteString
forall a. ToJSON a => a -> ByteString
encode Receipt
r) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxReceiptBytes = () -> Either String ()
forall a b. b -> Either a b
Right ()
    | Bool
otherwise =
        String -> Either String ()
forall a b. a -> Either a b
Left
            ( String
"receipt for row "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BSL.length (Receipt -> ByteString
forall a. ToJSON a => a -> ByteString
encode Receipt
r))
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" bytes, over the "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
maxReceiptBytes
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" limit"
            )

{- | The derivation decision (NOTE-067): compare the produced
address against the reference and return both. Pure so the
wiring is unit-testable and mutation-provable: replacing the
comparison with True must make an observed-negative fail.
-}
derivationMatches :: (Eq a) => a -> a -> (a, Bool)
derivationMatches :: forall a. Eq a => a -> a -> (a, Bool)
derivationMatches a
actual a
expected = (a
actual, a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected)

{- | Reference provenance labelling (NOTE-086): match and refused
outcomes must cite chain observation (with outref); distinct
outcomes must cite pinned-unapplied blueprint identity.
-}
mislabelled :: DerivationEvidence -> Bool
mislabelled :: DerivationEvidence -> Bool
mislabelled DerivationEvidence
d = case DerivationEvidence -> DerivationOutcome
deOutcome DerivationEvidence
d of
    DerivationOutcome
DerivMatch -> Bool -> Bool
not (Text -> Bool
chainObservedWithOutref (DerivationEvidence -> Text
deReferenceSource DerivationEvidence
d))
    DerivationOutcome
DerivRefused -> Bool -> Bool
not (Text -> Bool
chainObservedWithOutref (DerivationEvidence -> Text
deReferenceSource DerivationEvidence
d))
    DerivationOutcome
DerivDistinct -> DerivationEvidence -> Text
deReferenceSource DerivationEvidence
d Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"pinned-unapplied"

{- | chain-observed with a nonempty actual outref suffix (NOTE-089:
bare chain-observed with no identity proves no observation).
-}
chainObservedWithOutref :: Text -> Bool
chainObservedWithOutref :: Text -> Bool
chainObservedWithOutref Text
t = case Text -> Text -> Maybe Text
T.stripPrefix Text
"chain-observed " Text
t of
    Just Text
rest -> Bool -> Bool
not (Text -> Bool
T.null (Text -> Text
T.strip Text
rest))
    Maybe Text
Nothing -> Bool
False

{- | applied-validator-identity completeness: exactly the state match, the request
distinct and the corrupted refusal — a missing negative is an
incomplete receipt, never a pass.
-}
completeAppliedValidatorIdentity :: [DerivationEvidence] -> Bool
completeAppliedValidatorIdentity :: [DerivationEvidence] -> Bool
completeAppliedValidatorIdentity [DerivationEvidence]
ds =
    [(Text, DerivationOutcome)] -> [(Text, DerivationOutcome)]
forall a. Ord a => [a] -> [a]
sort [(DerivationEvidence -> Text
deValidator DerivationEvidence
d, DerivationEvidence -> DerivationOutcome
deOutcome DerivationEvidence
d) | DerivationEvidence
d <- [DerivationEvidence]
ds]
        [(Text, DerivationOutcome)] -> [(Text, DerivationOutcome)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Text, DerivationOutcome)] -> [(Text, DerivationOutcome)]
forall a. Ord a => [a] -> [a]
sort
            [ (Text
"request.request", DerivationOutcome
DerivDistinct)
            , (Text
"state.state", DerivationOutcome
DerivMatch)
            , (Text
"state.state", DerivationOutcome
DerivRefused)
            ]

{- | Load every @receipt-*.json@ in a directory. A malformed receipt,
an accepted row with no transactions or measurements, a refused row
with no attribution, a partial verdict without its constructor
accounting, a success verdict carrying partial constructors, or
two receipts for one row is an error naming the file: evidence
that does not parse is not evidence, and a guard that cannot fail
is not a guard.
-}
loadReceipts :: FilePath -> IO (Either String [Receipt])
loadReceipts :: String -> IO (Either String [Receipt])
loadReceipts String
dir = do
    exists <- String -> IO Bool
doesDirectoryExist String
dir
    if not exists
        then
            pure
                ( Left
                    ("receipt directory does not exist: " <> dir)
                )
        else do
            names <- listDirectory dir
            let files =
                    [ String
dir String -> ShowS
</> String
n
                    | String
n <- [String]
names
                    , String
"receipt-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
n
                    , String
".json" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
n
                    ]
            parsed <- mapM loadOne files
            pure (sequence parsed >>= checkReceipts)
  where
    loadOne :: String -> IO (Either String Receipt)
loadOne String
path = do
        content <- String -> IO ByteString
BSL.readFile String
path
        pure $ case eitherDecode content of
            Left String
err ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" does not parse: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err)
            Right Receipt
r ->
                String -> Receipt -> Either String Receipt
checkOne String
path Receipt
r
                    Either String Receipt
-> (Receipt -> Either String Receipt) -> Either String Receipt
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Receipt -> Either String Receipt
checkPartial String
path
                    Either String Receipt
-> (Receipt -> Either String Receipt) -> Either String Receipt
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Receipt -> Either String Receipt
checkDerivation String
path
                    Either String Receipt
-> (Receipt -> Either String Receipt) -> Either String Receipt
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Receipt -> Either String Receipt
checkEdge String
path
                    Either String Receipt
-> (Receipt -> Either String Receipt) -> Either String Receipt
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Receipt -> Either String Receipt
checkReplay String
path
    checkDerivation :: String -> Receipt -> Either String Receipt
checkDerivation String
path Receipt
r = case Receipt -> Maybe [DerivationEvidence]
receiptDerivation Receipt
r of
        Maybe [DerivationEvidence]
Nothing ->
            if Receipt -> Text
receiptRow Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"applied-validator-identity"
                then
                    String -> Either String Receipt
forall a b. a -> Either a b
Left
                        ( String
path
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": applied-validator-identity receipt names no derivation evidence — unknown or incomplete, never covered"
                        )
                else Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
r
        Just [DerivationEvidence]
ds
            | Receipt -> Text
receiptRow Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"applied-validator-identity" ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": only applied-validator-identity carries derivation evidence"
                    )
            | Bool -> Bool
not ([DerivationEvidence] -> Bool
completeAppliedValidatorIdentity [DerivationEvidence]
ds) ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": applied-validator-identity derivation evidence is incomplete — want state match, request distinct and corrupted refused"
                    )
            | [DerivationEvidence] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DerivationEvidence]
ds ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": derivation evidence is empty")
            | (DerivationEvidence -> Bool) -> [DerivationEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Bool
T.null (Text -> Bool)
-> (DerivationEvidence -> Text) -> DerivationEvidence -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivationEvidence -> Text
deValidator) [DerivationEvidence]
ds
                Bool -> Bool -> Bool
|| (DerivationEvidence -> Bool) -> [DerivationEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Bool
T.null (Text -> Bool)
-> (DerivationEvidence -> Text) -> DerivationEvidence -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivationEvidence -> Text
deComputed) [DerivationEvidence]
ds
                Bool -> Bool -> Bool
|| (DerivationEvidence -> Bool) -> [DerivationEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Bool
T.null (Text -> Bool)
-> (DerivationEvidence -> Text) -> DerivationEvidence -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivationEvidence -> Text
deReference) [DerivationEvidence]
ds ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": derivation evidence names empty validator or address")
            | (DerivationEvidence -> Bool) -> [DerivationEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
derivationVenue) (Text -> Bool)
-> (DerivationEvidence -> Text) -> DerivationEvidence -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivationEvidence -> Text
deVenue) [DerivationEvidence]
ds ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": derivation venue must be "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
derivationVenue
                    )
            | (DerivationEvidence -> Bool) -> [DerivationEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Bool
T.null (Text -> Bool)
-> (DerivationEvidence -> Text) -> DerivationEvidence -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivationEvidence -> Text
deReferenceSource) [DerivationEvidence]
ds ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": derivation evidence names no reference provenance")
            | (DerivationEvidence -> Bool) -> [DerivationEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any DerivationEvidence -> Bool
mislabelled [DerivationEvidence]
ds ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": derivation reference provenance mislabelled (match/refused want chain-observed plus outref, distinct wants pinned-unapplied)"
                    )
            | Bool
otherwise -> Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
r
    checkEdge :: String -> Receipt -> Either String Receipt
checkEdge String
path Receipt
r = case (Receipt -> Text
receiptRow Receipt
r, Receipt -> Maybe [Value]
receiptSteps Receipt
r) of
        (Text
"retract-outside-window", Just [Value]
steps) -> do
            checked <- String -> Receipt -> [Value] -> Either String Receipt
stepsComplete String
path Receipt
r [Value]
steps
            let field Key
name (Object Object
fields) = Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
name Object
fields
                field Key
_ Value
_ = Maybe Value
forall a. Maybe a
Nothing
                outcome Key
name Value
step = Key -> Value -> Maybe Value
field Key
"outcome" (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
field Key
name Value
step
            if map (field "tamper") steps
                == map Just [String "before-phase-2", Null, String "after-phase-2"]
                && all ((== Just (String "retract")) . field "exit") steps
                && all ((== Just (String "agrees")) . field "comparison") steps
                && all
                    ( \Key
name ->
                        (Value -> Maybe Value) -> [Value] -> [Maybe Value]
forall a b. (a -> b) -> [a] -> [b]
map (Key -> Value -> Maybe Value
outcome Key
name) [Value]
steps
                            [Maybe Value] -> [Maybe Value] -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> Maybe Value) -> [Text] -> [Maybe Value]
forall a b. (a -> b) -> [a] -> [b]
map (Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> (Text -> Value) -> Text -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String) [Text
"refused", Text
"accepted", Text
"refused"]
                    )
                    ["model", "chain"]
                then Right checked
                else
                    Left
                        (path <> ": retraction window requires before, accepted control, after")
        (Text
row, Just [Value]
steps)
            | Maybe Program -> Bool
forall a. Maybe a -> Bool
isNothing (String -> Maybe Program
programFor (Text -> String
T.unpack Text
row))
            , Text
row Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
historicalStepRows ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": only a program's receipt carries steps")
            -- #287: an attribution receipt carrying, beside its own outcome,
            -- the batch comparisons none of which landed, as the conformance
            -- session wrote them before its rows were programs.
            | (Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Value -> Bool
isBatchStep [Value]
steps
            , Bool -> Bool
not ((Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Value -> Bool
landed [Value]
steps) ->
                String -> Receipt -> [Value] -> Either String Receipt
batchSteps String
path Receipt
r [Value]
steps
            -- Every program's receipt: one record per compared request or batch.
            | Bool
otherwise -> String -> Receipt -> [Value] -> Either String Receipt
stepsComplete String
path Receipt
r [Value]
steps
        (Text
"register-active-key", Maybe [Value]
Nothing) -> String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": registration names no live steps")
        (Text
"retire-active-key", Maybe [Value]
Nothing) -> String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": retirement names no live steps")
        (Text
"permanent-retire-active-key", Maybe [Value]
Nothing) -> String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": retirement names no live steps")
        (Text
"retract-outside-window", Maybe [Value]
Nothing) -> String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": retraction window names no live steps")
        (Text
"reject-and-retract-refund-controls", Maybe [Value]
Nothing) -> String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": exit chapter names no live steps")
        (Text
"reject-inside-processing-and-retraction-windows", Maybe [Value]
Nothing) -> String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": early rejection names no live steps")
        (Text
"sequence", Maybe [Value]
Nothing) -> String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": sequence names no live steps")
        (Text
_, Maybe [Value]
Nothing) -> Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
r
    -- Archived programs remain readable with the same structural evidence
    -- checks. This does not restore a runner: effectiveState separately binds
    -- every receipt to its recorded code revision before giving it credit.
    historicalStepRows :: [Text]
historicalStepRows =
        [ Text
"update-existing-key"
        , Text
"delete-existing-key"
        , Text
"reinsert-deleted-key"
        , Text
"retire-active-key"
        ]
    isBatchStep :: Value -> Bool
isBatchStep Value
step = case Value
step of
        Object Object
fields -> Key -> Object -> Bool
forall a. Key -> KeyMap a -> Bool
KM.member Key
"batch" Object
fields
        Value
_ -> Bool
False
    landed :: Value -> Bool
landed Value
step = case Value
step of
        Object Object
fields
            | Just (Object Object
chain) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"chain" Object
fields ->
                Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"outcome" Object
chain Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
"accepted")
        Value
_ -> Bool
False

    checkPartial :: String -> Receipt -> Either String Receipt
checkPartial String
path Receipt
r = case (Receipt -> Verdict
receiptVerdict Receipt
r, Receipt -> Maybe PartialInfo
receiptPartial Receipt
r) of
        (Verdict
_, Maybe PartialInfo
Nothing) -> case Text -> Maybe [(Text, Integer)]
declaredConstructors (Receipt -> Text
receiptRow Receipt
r) of
            Maybe [(Text, Integer)]
Nothing -> Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
r
            Just [(Text, Integer)]
_ ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": row "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" names no constructor accounting — unknown or incomplete, never covered"
                    )
        (Verdict
Partial, Just PartialInfo
pinfo) -> String -> Receipt -> PartialInfo -> Either String Receipt
checkPartialConstructors String
path Receipt
r PartialInfo
pinfo
        (Verdict
v, Just PartialInfo
_) ->
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
path
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": receipt claims "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Verdict -> String
forall a. Show a => a -> String
show Verdict
v
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" while carrying partial constructors"
                )
    checkPartialConstructors :: String -> Receipt -> PartialInfo -> Either String Receipt
checkPartialConstructors String
path Receipt
r PartialInfo
pinfo =
        case Text -> Maybe [(Text, Integer)]
declaredConstructors (Receipt -> Text
receiptRow Receipt
r) of
            Maybe [(Text, Integer)]
Nothing ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": partial row "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" declares no constructor set"
                    )
            Just [(Text, Integer)]
declared
                | [(Text, Integer)] -> [(Text, Integer)]
sortPairs [(Text, Integer)]
have [(Text, Integer)] -> [(Text, Integer)] -> Bool
forall a. Eq a => a -> a -> Bool
/= [(Text, Integer)] -> [(Text, Integer)]
sortPairs [(Text, Integer)]
declared ->
                    String -> Either String Receipt
forall a b. a -> Either a b
Left
                        ( String
path
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": partial row "
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" accounts "
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(Text, Integer)] -> String
forall a. Show a => a -> String
show [(Text, Integer)]
have
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", declared "
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(Text, Integer)] -> String
forall a. Show a => a -> String
show [(Text, Integer)]
declared
                        )
                | (ConstructorEvidence -> Bool) -> [ConstructorEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ConstructorEvidence -> Bool
refusedStanding [ConstructorEvidence]
ces ->
                    String -> Either String Receipt
forall a b. a -> Either a b
Left
                        ( String
path
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": partial row "
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" carries a refused constructor witness — this bounded schema admits none (NOTE-055 fail-closed; no production row exercises a refusal witness)"
                        )
                | [ConstructorEvidence] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorEvidence]
residuals ->
                    String -> Either String Receipt
forall a b. a -> Either a b
Left
                        ( String
path
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": partial row "
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" verdict partial lists no residual or gap constructor"
                        )
                | Bool -> Bool
not ((ConstructorEvidence -> Bool) -> [ConstructorEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructorEvidence -> Bool
boundAccepts [ConstructorEvidence]
accepts) ->
                    String -> Either String Receipt
forall a b. a -> Either a b
Left
                        ( String
path
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": partial row "
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" names accepted-constructor evidence outside its transactions"
                        )
                | (ConstructorEvidence -> Bool) -> [ConstructorEvidence] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Bool
T.null (Text -> Bool)
-> (ConstructorEvidence -> Text) -> ConstructorEvidence -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorEvidence -> Text
ceEvidence) [ConstructorEvidence]
ces ->
                    String -> Either String Receipt
forall a b. a -> Either a b
Left
                        ( String
path
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": partial row "
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" carries empty constructor evidence"
                        )
                | Bool
otherwise -> Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
r
      where
        ces :: [ConstructorEvidence]
ces = PartialInfo -> [ConstructorEvidence]
partialConstructors PartialInfo
pinfo
        have :: [(Text, Integer)]
have = [(ConstructorEvidence -> Text
ceConstructor ConstructorEvidence
c, ConstructorEvidence -> Integer
ceIndex ConstructorEvidence
c) | ConstructorEvidence
c <- [ConstructorEvidence]
ces]
        sortPairs :: [(Text, Integer)] -> [(Text, Integer)]
sortPairs = [(Text, Integer)] -> [(Text, Integer)]
forall a. Ord a => [a] -> [a]
sort
        residuals :: [ConstructorEvidence]
residuals =
            [ ConstructorEvidence
c
            | ConstructorEvidence
c <- [ConstructorEvidence]
ces
            , ConstructorEvidence -> ConstructorStanding
ceStanding ConstructorEvidence
c ConstructorStanding -> ConstructorStanding -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorStanding
StandingResidual Bool -> Bool -> Bool
|| ConstructorEvidence -> ConstructorStanding
ceStanding ConstructorEvidence
c ConstructorStanding -> ConstructorStanding -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorStanding
StandingGap
            ]
        refusedStanding :: ConstructorEvidence -> Bool
refusedStanding ConstructorEvidence
c = ConstructorEvidence -> ConstructorStanding
ceStanding ConstructorEvidence
c ConstructorStanding -> ConstructorStanding -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorStanding
StandingRefused
        accepts :: [ConstructorEvidence]
accepts = [ConstructorEvidence
c | ConstructorEvidence
c <- [ConstructorEvidence]
ces, ConstructorEvidence -> ConstructorStanding
ceStanding ConstructorEvidence
c ConstructorStanding -> ConstructorStanding -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorStanding
StandingAccepted]
        boundAccepts :: ConstructorEvidence -> Bool
boundAccepts ConstructorEvidence
c = ConstructorEvidence -> Text
ceEvidence ConstructorEvidence
c Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Receipt -> [Text]
receiptTransactions Receipt
r
    checkOne :: String -> Receipt -> Either String Receipt
checkOne String
path Receipt
r = case Receipt -> Outcome
receiptOutcome Receipt
r of
        Outcome
Accepted -> String -> Receipt -> Either String Receipt
checkAccepted String
path Receipt
r
        Outcome
Refused
            | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Receipt -> [Text]
receiptTransactions Receipt
r)
            , Just RefusalInfo
info <- Receipt -> Maybe RefusalInfo
receiptRefusal Receipt
r
            , Receipt -> Text
receiptVenue Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"node-submit"
            , Just Text
_ <- Receipt -> Maybe Text
receiptRejected Receipt
r ->
                String -> Receipt -> RefusalInfo -> Either String Receipt
checkRefused String
path Receipt
r RefusalInfo
info
            | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Receipt -> [Text]
receiptTransactions Receipt
r)
            , Just RefusalInfo
info <- Receipt -> Maybe RefusalInfo
receiptRefusal Receipt
r
            , Receipt -> Text
receiptVenue Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"ledger-eval"
            , Maybe Text
Nothing <- Receipt -> Maybe Text
receiptRejected Receipt
r ->
                String -> Receipt -> RefusalInfo -> Either String Receipt
checkRefused String
path Receipt
r RefusalInfo
info
            | Bool
otherwise ->
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": refused row "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" must carry a refusal, no transactions, and "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"a rejected id exactly for node-submit"
                    )
    -- Structural refusal fields (NOTE-071): observed phase,
    -- extracted hashes, and an explicit branch-or-limit. Legacy
    -- absence cannot claim the new attributed observation.
    checkRefused :: String -> Receipt -> RefusalInfo -> Either String Receipt
checkRefused String
path Receipt
r RefusalInfo
info = Either String Receipt
checkPhase
      where
        rowName :: String
rowName = Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
r)
        checkPhase :: Either String Receipt
checkPhase =
            if RefusalInfo -> Text
refusalPhase RefusalInfo
info Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"phase-2"
                then
                    String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": refused row " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
rowName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" phase is not phase-2")
                else Either String Receipt
checkHashes
        checkHashes :: Either String Receipt
checkHashes
            | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RefusalInfo -> [Text]
refusalHashes RefusalInfo
info) =
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": refused row "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
rowName
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" names no extracted failure hashes"
                    )
            | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Text -> Bool
T.null (RefusalInfo -> [Text]
refusalHashes RefusalInfo
info) =
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": refused row " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
rowName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" names an empty failure hash")
            | Bool
otherwise = Either String Receipt
checkBranch
        checkBranch :: Either String Receipt
checkBranch
            | Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (RefusalInfo -> Maybe Text
refusalBranch RefusalInfo
info) Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (RefusalInfo -> Maybe Text
refusalLimit RefusalInfo
info) =
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": refused row "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
rowName
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" states neither a named branch nor its limit"
                    )
            | (Maybe Text -> Bool) -> [Maybe Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe Text -> Bool
emptyJust [RefusalInfo -> Maybe Text
refusalBranch RefusalInfo
info, RefusalInfo -> Maybe Text
refusalLimit RefusalInfo
info] =
                String -> Either String Receipt
forall a b. a -> Either a b
Left
                    ( String
path
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": refused row "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
rowName
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" carries an empty branch or limit"
                    )
            | Bool
otherwise = Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
r
        emptyJust :: Maybe Text -> Bool
emptyJust (Just Text
t) = Text -> Bool
T.null Text
t
        emptyJust Maybe Text
Nothing = Bool
False
    checkAccepted :: String -> Receipt -> Either String Receipt
checkAccepted String
p Receipt
x
        | Receipt -> Text
receiptRow Receipt
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"applied-validator-identity"
        , Receipt -> Text
receiptVenue Receipt
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
derivationVenue =
            String -> Receipt -> Either String Receipt
forall {a}.
(Semigroup a, IsString a) =>
a -> Receipt -> Either a Receipt
checkAppliedValidatorIdentityAccepted String
p Receipt
x
        | Receipt -> Text
receiptRow Receipt
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"applied-validator-identity" =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": applied-validator-identity venue must be "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
derivationVenue
                )
        | Receipt -> Text
receiptVenue Receipt
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"node-submit" = String -> Receipt -> Either String Receipt
checkNodeAccepted String
p Receipt
x
        | Receipt -> Text
receiptVenue Receipt
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"blueprint-check"
        , Receipt -> Text
receiptRow Receipt
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"blueprint-encoding-round-trip" =
            String -> Receipt -> Either String Receipt
checkLocalAccepted String
p Receipt
x
        | Receipt -> Text
receiptVenue Receipt
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"param-check"
        , Receipt -> Text
receiptRow Receipt
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"script-parameter-application" =
            String -> Receipt -> Either String Receipt
checkLocalAccepted String
p Receipt
x
        | Bool
otherwise =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted row "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has venue "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptVenue Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", want node-submit or its own local venue"
                )
    checkAppliedValidatorIdentityAccepted :: a -> Receipt -> Either a Receipt
checkAppliedValidatorIdentityAccepted a
p Receipt
x
        | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Receipt -> [Text]
receiptTransactions Receipt
x) =
            a -> Either a Receipt
forall a b. a -> Either a b
Left
                ( a
p
                    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
": applied-validator-identity row names no provenance boot transaction"
                )
        | (Maybe Integer -> Bool) -> [Maybe Integer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe Integer -> Bool
forall a. Maybe a -> Bool
isNothing [Receipt -> Maybe Integer
receiptMem Receipt
x, Receipt -> Maybe Integer
receiptCpu Receipt
x, Receipt -> Maybe Integer
receiptTxSize Receipt
x] =
            a -> Either a Receipt
forall a b. a -> Either a b
Left
                ( a
p
                    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
": applied-validator-identity row misses measurements"
                )
        | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Receipt -> Maybe Text
receiptRejected Receipt
x) =
            a -> Either a Receipt
forall a b. a -> Either a b
Left
                ( a
p
                    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
": applied-validator-identity row must not name a rejected transaction"
                )
        | Maybe RefusalInfo -> Bool
forall a. Maybe a -> Bool
isJust (Receipt -> Maybe RefusalInfo
receiptRefusal Receipt
x) =
            a -> Either a Receipt
forall a b. a -> Either a b
Left
                ( a
p
                    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
": applied-validator-identity row must not carry a refusal"
                )
        | Bool
otherwise = Receipt -> Either a Receipt
forall a b. b -> Either a b
Right Receipt
x
    checkNodeAccepted :: String -> Receipt -> Either String Receipt
checkNodeAccepted String
p Receipt
x
        | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Receipt -> [Text]
receiptTransactions Receipt
x) =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted row "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" names no transaction"
                )
        | (Maybe Integer -> Bool) -> [Maybe Integer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe Integer -> Bool
forall a. Maybe a -> Bool
isNothing [Receipt -> Maybe Integer
receiptMem Receipt
x, Receipt -> Maybe Integer
receiptCpu Receipt
x, Receipt -> Maybe Integer
receiptTxSize Receipt
x] =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted row "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" misses measurements"
                )
        | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Receipt -> Maybe Text
receiptRejected Receipt
x) =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted row "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" must not name a rejected transaction"
                )
        | Bool
otherwise = Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
x
    checkLocalAccepted :: String -> Receipt -> Either String Receipt
checkLocalAccepted String
p Receipt
x
        | Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Receipt -> [Text]
receiptTransactions Receipt
x)) =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted row "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is local and must name no transaction"
                )
        | Receipt -> Maybe Integer
receiptMem Receipt
x Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0 Bool -> Bool -> Bool
|| Receipt -> Maybe Integer
receiptCpu Receipt
x Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0 =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted row "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is local and must record zero units"
                )
        | Maybe Integer
Nothing <- Receipt -> Maybe Integer
receiptTxSize Receipt
x =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted row "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" misses measurements"
                )
        | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Receipt -> Maybe Text
receiptRejected Receipt
x) =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted row "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" must not name a rejected transaction"
                )
        | Maybe RefusalInfo -> Bool
forall a. Maybe a -> Bool
isJust (Receipt -> Maybe RefusalInfo
receiptRefusal Receipt
x) =
            String -> Either String Receipt
forall a b. a -> Either a b
Left
                ( String
p
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": accepted row "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Receipt -> Text
receiptRow Receipt
x)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" must not carry a refusal"
                )
        | Bool
otherwise = Receipt -> Either String Receipt
forall a b. b -> Either a b
Right Receipt
x
    checkReceipts :: [Receipt] -> Either a [Receipt]
checkReceipts [Receipt]
rs
        | [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
rows Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> [Text]
forall {a}. Eq a => [a] -> [a]
nub [Text]
rows) =
            a -> Either a [Receipt]
forall a b. a -> Either a b
Left a
"two receipts for one row"
        | Bool
otherwise = [Receipt] -> Either a [Receipt]
forall a b. b -> Either a b
Right [Receipt]
rs
      where
        rows :: [Text]
rows = (Receipt -> Text) -> [Receipt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Receipt -> Text
receiptRow [Receipt]
rs
        nub :: [a] -> [a]
nub [] = []
        nub (a
x : [a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
nub ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
x) [a]
xs)

{- | The current tree's base commit. 'Nothing' when git cannot say
(no checkout, no git): receipts then match nothing and @list@
prints the declared plan with a warning.
-}
currentBase :: IO (Maybe Text)
currentBase :: IO (Maybe Text)
currentBase = do
    (code, out, _) <-
        String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"git" [String
"rev-parse", String
"HEAD"] String
""
    case code of
        ExitCode
ExitSuccess ->
            Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
T.strip (String -> Text
T.pack String
out)))
        ExitCode
_ -> do
            Handle -> String -> IO ()
hPutStrLn
                Handle
stderr
                String
"conformance list: git base unknown; \
                \printing the declared plan"
            Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing

{- | A batch record, as the runner writes one for a batch submitted in one
transaction and asked of the model's matching batch question: its registry, the
question and the requests asked, a known tamper or none, the model's and the
chain's outcomes and their comparison. A refusal names the scripts its hashes
are; an agreement has one outcome on both sides, and a tampered batch agrees
only by both refusing.
-}
batchRecordProblem :: FilePath -> Value -> Either String ()
batchRecordProblem :: String -> Value -> Either String ()
batchRecordProblem String
path Value
step = do
    case (Key -> Maybe Value
at Key
"registry", Key -> Maybe Value
at Key
"batch", Key -> Maybe Value
at Key
"requests") of
        (Just (Number Scientific
_), Just (String Text
name), Just (Array Array
_))
            | Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"foldBatch", Text
"rejectBatch"] -> () -> Either String ()
forall a b. b -> Either a b
Right ()
        (Maybe Value, Maybe Value, Maybe Value)
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"missing registry, batch question or requests"
    case Key -> Maybe Value
at Key
"tamper" of
        Maybe Value
Nothing -> () -> Either String ()
forall a b. b -> Either a b
Right ()
        Just Value
Null -> () -> Either String ()
forall a b. b -> Either a b
Right ()
        Just (String Text
name)
            | Text
name
                Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ( (BatchTamper -> Text) -> [BatchTamper] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (BatchTamper -> String) -> BatchTamper -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchTamper -> String
batchTamperName) [BatchTamper
forall a. Bounded a => a
minBound .. BatchTamper
forall a. Bounded a => a
maxBound :: BatchTamper]
                            [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (RefundTamper -> Text) -> [RefundTamper] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
                                (String -> Text
T.pack (String -> Text)
-> (RefundTamper -> String) -> RefundTamper -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefundTamper -> String
refundTamperName)
                                [RefundTamper
CrossedRefunds, Integer -> RefundTamper
ShortFirstRefund Integer
1, Integer -> RefundTamper
SplitFirstRefund Integer
1]
                       ) ->
                () -> Either String ()
forall a b. b -> Either a b
Right ()
        Maybe Value
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"unknown batch tamper"
    let model :: Maybe Value
model = Key -> Key -> Maybe Value
within Key
"model" Key
"outcome"
        chain :: Maybe Value
chain = Key -> Key -> Maybe Value
within Key
"chain" Key
"outcome"
    case (Maybe Value
model, Maybe Value
chain, Key -> Maybe Value
at Key
"comparison") of
        (Just (String Text
m), Just (String Text
c), Just (String Text
verdict))
            | Text
m Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"accepted", Text
"refused", Text
"unsupported"]
            , Text
c Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"accepted", Text
"refused", Text
"unsupported"]
            , Text
verdict Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"agrees", Text
"disagrees"] ->
                () -> Either String ()
forall a b. b -> Either a b
Right ()
        (Maybe Value, Maybe Value, Maybe Value)
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"missing or unknown model, chain or comparison outcome"
    case Maybe Value
chain of
        Just (String Text
"accepted") -> case Key -> Key -> Maybe Value
within Key
"chain" Key
"txid" of
            Just (String Text
_) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            Maybe Value
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"accepted batch names no transaction"
        Just (String Text
"refused") -> case Key -> Maybe Value
at Key
"chain" Maybe Value -> (Value -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Value -> Maybe Value
field Key
"refusal" of
            Just (Object Object
refusal)
                | Just (Array Array
hashes) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"hashes" Object
refusal
                , Bool -> Bool
not (Array -> Bool
forall a. Vector a -> Bool
Vector.null Array
hashes) ->
                    () -> Either String ()
forall a b. b -> Either a b
Right ()
            Maybe Value
_ -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"refused batch names no refusing script"
        Maybe Value
_ -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    case Key -> Maybe Value
at Key
"comparison" of
        Just (String Text
"agrees")
            | Maybe Value
model Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Value
chain -> String -> Either String ()
forall {b}. String -> Either String b
failure String
"batch agreement changes the outcome"
            | Key -> Maybe Value
at Key
"tamper" Maybe Value -> [Maybe Value] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe Value
forall a. Maybe a
Nothing, Value -> Maybe Value
forall a. a -> Maybe a
Just Value
Null]
            , Maybe Value
chain Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
"refused") ->
                String -> Either String ()
forall {b}. String -> Either String b
failure
                    String
"tampered batch agreement does not have model and chain refusal"
        Maybe Value
_ -> () -> Either String ()
forall a b. b -> Either a b
Right ()
  where
    at :: Key -> Maybe Value
at Key
name = Key -> Value -> Maybe Value
field Key
name Value
step
    within :: Key -> Key -> Maybe Value
within Key
outer Key
inner = Key -> Maybe Value
at Key
outer Maybe Value -> (Value -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Value -> Maybe Value
field Key
inner
    field :: Key -> Value -> Maybe Value
field Key
name = \case
        Object Object
fields -> Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
name Object
fields
        Value
_ -> Maybe Value
forall a. Maybe a
Nothing
    failure :: String -> Either String b
failure String
reason = String -> Either String b
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": invalid batch record: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
reason)

-- | A row's batch records beside its attributed refusal: every one valid.
batchSteps :: FilePath -> Receipt -> [Value] -> Either String Receipt
batchSteps :: String -> Receipt -> [Value] -> Either String Receipt
batchSteps String
path Receipt
receipt [Value]
steps
    | [Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
steps = String -> Either String Receipt
forall a b. a -> Either a b
Left (String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": batch steps name no batch")
    | Bool
otherwise = Receipt
receipt Receipt -> Either String () -> Either String Receipt
forall a b. a -> Either String b -> Either String a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Value -> Either String ()) -> [Value] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Value -> Either String ()
batchRecordProblem String
path) [Value]
steps

{- | Why a row stands @unmet-by-ruling@: the two meanings the operator's
rulings give that one verdict, each with the issue that would close it.
-}
data UnmetRuling
    = {- | the registry deliberately does not do what the consumer's theorem
      requires (ruling 2026-10-01); the alignment issue
      -}
      ConsumerRequirementUnmet Text
    | {- | the chain refuses and Lean has no counterpart to compare with
      (ruling 2026-10-02, "Narrow #287"); the model follow-up
      -}
      NoModelCounterpart Text
    deriving stock (Int -> UnmetRuling -> ShowS
[UnmetRuling] -> ShowS
UnmetRuling -> String
(Int -> UnmetRuling -> ShowS)
-> (UnmetRuling -> String)
-> ([UnmetRuling] -> ShowS)
-> Show UnmetRuling
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnmetRuling -> ShowS
showsPrec :: Int -> UnmetRuling -> ShowS
$cshow :: UnmetRuling -> String
show :: UnmetRuling -> String
$cshowList :: [UnmetRuling] -> ShowS
showList :: [UnmetRuling] -> ShowS
Show, UnmetRuling -> UnmetRuling -> Bool
(UnmetRuling -> UnmetRuling -> Bool)
-> (UnmetRuling -> UnmetRuling -> Bool) -> Eq UnmetRuling
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnmetRuling -> UnmetRuling -> Bool
== :: UnmetRuling -> UnmetRuling -> Bool
$c/= :: UnmetRuling -> UnmetRuling -> Bool
/= :: UnmetRuling -> UnmetRuling -> Bool
Eq)

{- | The ruling that keeps each unmet row unmet. A row recorded
@unmet-by-ruling@ that is not listed has no stated meaning, and a reader
surface refuses to render it.
-}
unmetRuling :: Text -> Maybe UnmetRuling
unmetRuling :: Text -> Maybe UnmetRuling
unmetRuling = \case
    Text
"reject-before-deadline-consumer-requirement" -> UnmetRuling -> Maybe UnmetRuling
forall a. a -> Maybe a
Just (Text -> UnmetRuling
ConsumerRequirementUnmet Text
"lambdasistemi/cardano-keri#468")
    Text
"fold-against-superseded-root" -> UnmetRuling -> Maybe UnmetRuling
forall a. a -> Maybe a
Just (Text -> UnmetRuling
NoModelCounterpart Text
"lambdasistemi/singular#346")
    Text
"surplus-fold-actions" -> UnmetRuling -> Maybe UnmetRuling
forall a. a -> Maybe a
Just (Text -> UnmetRuling
NoModelCounterpart Text
"lambdasistemi/singular#345")
    Text
"wrong-redeemer-constructor-index" -> UnmetRuling -> Maybe UnmetRuling
forall a. a -> Maybe a
Just (Text -> UnmetRuling
NoModelCounterpart Text
"lambdasistemi/singular#347")
    Text
_ -> Maybe UnmetRuling
forall a. Maybe a
Nothing

-- | An unmet ruling in plain words, naming the issue that would close it.
unmetReading :: UnmetRuling -> Text
unmetReading :: UnmetRuling -> Text
unmetReading = \case
    ConsumerRequirementUnmet Text
issue ->
        Text
"unmet by a ruling: the registry deliberately does not do what the \
        \consumer requirement states (operator ruling 2026-10-01; "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
issue
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    NoModelCounterpart Text
issue ->
        Text
"unmet by a ruling: the chain refuses, Lean has no counterpart to \
        \compare with (operator ruling 2026-10-02 \"Narrow #287\"); follow-up "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
issue