{- |
Module      : Conformance.Refusal
Description : Phase-2 refusal attribution for refused rows
License     : Apache-2.0

A refusal closes a refuse-row only when it is attributable: the node
must have refused in phase 2 (@PlutusFailure@) naming the script that
refused (@marker@, the applied script hash hex). A phase-1 refusal
proves nothing about the binding, and a reason that does not name the
script proves nothing about which guard held. This is the #41
discipline as @offchain\/journey\/li-refusals\/Main.hs@ applies it.

'wrongReasonMarker' arms the negative control: matched against a
marker no node reason can ever contain, the matcher must fail naming
what came back (@CONFORMANCE_CONTROL=wrong-reason@).
-}
module Conformance.Refusal
    ( RefusalMismatch (..)
    , RefusalRole (..)
    , TracedRefusal (..)
    , untraced
    , attributeRefusalReceipt
    , matchRefusal
    , refusalScriptHashes
    , refusalWritesReceipt
    , trimRefusal
    , wrongReasonMarker
    ) where

import Conformance.Receipt
    ( Outcome (..)
    , Receipt (..)
    , RefusalInfo (..)
    , ReplayCorrespondence (..)
    , ReplayEvidence (..)
    , Verdict (..)
    , writeReceiptFile
    )
import Control.Monad (when)
import Data.Char (isHexDigit)
import Data.List (intercalate, isInfixOf, isPrefixOf, nub, sortOn)
import Data.Maybe (catMaybes)
import Data.Text qualified as T

-- | How a refusal failed to attribute.
data RefusalMismatch
    = {- | The node refused outside phase 2: proves nothing about the
      script binding.
      -}
      NotPhase2
        { RefusalMismatch -> String
refusalReason :: String
        }
    | -- | The reason does not name the expected script.
      MarkerAbsent
        { RefusalMismatch -> String
refusalMarker :: String
        , refusalReason :: String
        }
    deriving stock (Int -> RefusalMismatch -> ShowS
[RefusalMismatch] -> ShowS
RefusalMismatch -> String
(Int -> RefusalMismatch -> ShowS)
-> (RefusalMismatch -> String)
-> ([RefusalMismatch] -> ShowS)
-> Show RefusalMismatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefusalMismatch -> ShowS
showsPrec :: Int -> RefusalMismatch -> ShowS
$cshow :: RefusalMismatch -> String
show :: RefusalMismatch -> String
$cshowList :: [RefusalMismatch] -> ShowS
showList :: [RefusalMismatch] -> ShowS
Show, RefusalMismatch -> RefusalMismatch -> Bool
(RefusalMismatch -> RefusalMismatch -> Bool)
-> (RefusalMismatch -> RefusalMismatch -> Bool)
-> Eq RefusalMismatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefusalMismatch -> RefusalMismatch -> Bool
== :: RefusalMismatch -> RefusalMismatch -> Bool
$c/= :: RefusalMismatch -> RefusalMismatch -> Bool
/= :: RefusalMismatch -> RefusalMismatch -> Bool
Eq)

{- | Require @reason@ to be a phase-2 script failure naming @marker@.
@marker@ is the applied refusing script's hash hex; @reason@ is the
node's refusal text verbatim. The marker must be AMONG the
extracted failure script hashes (NOTE-071) — a hash appearing in
unrelated diagnostic text must not satisfy the check.

Two vocabularies, one discipline. At submit the node speaks
@PlutusFailure@ (the li-refusals precedent). At build evaluation
the story language reports the node's per-purpose failure, whose text speaks
@CekError@: the CEK machine executed the script and it errored.
Both are the node's word for script-execution failure, never for a
phase-1 ledger refusal — and both must name the script.
-}
matchRefusal :: String -> String -> Either RefusalMismatch ()
matchRefusal :: String -> String -> Either RefusalMismatch ()
matchRefusal String
marker String
reason
    | Bool -> Bool
not (String -> Bool
isPhase2 String
reason) =
        RefusalMismatch -> Either RefusalMismatch ()
forall a b. a -> Either a b
Left (String -> RefusalMismatch
NotPhase2 String
reason)
    | String
marker String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String -> [String]
refusalScriptHashes String
reason =
        RefusalMismatch -> Either RefusalMismatch ()
forall a b. a -> Either a b
Left (String -> String -> RefusalMismatch
MarkerAbsent String
marker String
reason)
    | Bool
otherwise = () -> Either RefusalMismatch ()
forall a b. b -> Either a b
Right ()

-- | The node's word for "a script executed and failed".
isPhase2 :: String -> Bool
isPhase2 :: String -> Bool
isPhase2 String
reason =
    String
"PlutusFailure" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
reason
        Bool -> Bool -> Bool
|| String
"CekError" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
reason

{- | Keep the parts that attribute a refusal and drop the rest.
@show@ on an evaluation context embeds the whole compiled validator
(~30KB of base64) plus the cost model and script context; a receipt
carrying that is unreadable. Kept: the failure class and redeemer
pointer, the failed script hash, the CEK error. Everything else —
@plutusBinary@, @pwcCostModel@, the full @ScriptContext@ — comes
out; every failed script hash in ledger order binds which scripts
ran, and the receipt already carries the blueprint hashes.
-}
trimRefusal :: String -> String
trimRefusal :: ShowS
trimRefusal String
text =
    case [String]
parts of
        [] -> Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
500 String
text String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" [unparsed]"
        [String]
_ -> Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
2000 (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" | " [String]
parts)
  where
    parts :: [String]
parts =
        [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes
            [ String -> Maybe String
evalHead String
text
            , String -> Maybe String
plutusFailed String
text
            , String -> Maybe String
scriptHashes String
text
            , String -> Maybe String
cekError String
text
            ]

-- | Up to the node's validation report: failure class and purpose.
evalHead :: String -> Maybe String
evalHead :: String -> Maybe String
evalHead String
text
    | String
"\\\"ValidationFailure" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
text =
        String -> Maybe String
forall a. a -> Maybe a
Just (String -> ShowS
takeUntil String
"\\\"ValidationFailure" String
text)
    | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

-- | The node's verdict phrase for a submitted script failure.
plutusFailed :: String -> Maybe String
plutusFailed :: String -> Maybe String
plutusFailed String
text
    | String
"The PlutusV3 script failed" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
text =
        String -> Maybe String
forall a. a -> Maybe a
Just String
"PlutusV3 script failed (node-submit)"
    | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

{- | Every @ScriptHash \"...\"@ value in the reason, ledger order,
first occurrence wins. A malformed transaction can trip two validators
in one submission and the ledger's failure-list order is not stable,
so attribution keeps them all: trim volume — the script binary, the
cost model, the whole context — never the identities that attribute
the refusal. Both shapes name hashes this way: the eval shape via
@pwcScriptHash@, the node-submit shape in its failure headers.
Unquoted ledger credentials never match this pattern.
-}
refusalScriptHashes :: String -> [String]
refusalScriptHashes :: String -> [String]
refusalScriptHashes String
text = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (String -> [String]
go String
text))
  where
    go :: String -> [String]
go String
s = case String -> String -> Maybe String
findAfter String
hashMarker String
s of
        Maybe String
Nothing -> []
        Just String
after ->
            let digits :: String
digits = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isQuoteOrEscape String
after
                h :: String
h = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isHexDigit String
digits
            in  String
h String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
go (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
h) String
digits)
    -- Both node shapes: quoted ledger form and bare Haskell Show
    -- form. Only the marker-anchored hex run counts; unquoted
    -- ledger credentials never match this pattern.
    hashMarker :: String
hashMarker = String
"ScriptHash "
    isQuoteOrEscape :: Char -> Bool
isQuoteOrEscape Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'

-- | The failed scripts' hashes joined as one @scriptHash=@ field.
scriptHashes :: String -> Maybe String
scriptHashes :: String -> Maybe String
scriptHashes String
text = case String -> [String]
refusalScriptHashes String
text of
    [] -> Maybe String
forall a. Maybe a
Nothing
    [String]
hs -> String -> Maybe String
forall a. a -> Maybe a
Just (String
"scriptHash=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
hs)

{- | The machine error, capped: the cause, not the context. Ends at
the eval shape's context close or the node shape's protocol
version line, whichever is nearer.
-}
cekError :: String -> Maybe String
cekError :: String -> Maybe String
cekError String
text = do
    after <- String -> String -> Maybe String
findAfter String
"CekError " String
text
    pure
        ( "cek="
            <> take 500 (takeUntilAny [") []", "\\nThe protocol version is:"] after)
        )

-- | Text after the first occurrence of a marker.
findAfter :: String -> String -> Maybe String
findAfter :: String -> String -> Maybe String
findAfter String
marker String
text =
    case String -> ShowS
forall {a}. Eq a => [a] -> [a] -> [a]
dropUntil String
marker String
text of
        [] -> Maybe String
forall a. Maybe a
Nothing
        String
rest -> String -> Maybe String
forall a. a -> Maybe a
Just (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
marker) String
rest)
  where
    dropUntil :: [a] -> [a] -> [a]
dropUntil [a]
_ [] = []
    dropUntil [a]
m s :: [a]
s@(a
_ : [a]
cs)
        | [a]
m [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [a]
s = [a]
s
        | Bool
otherwise = [a] -> [a] -> [a]
dropUntil [a]
m [a]
cs

-- | Text up to the first occurrence of an end marker.
takeUntil :: String -> String -> String
takeUntil :: String -> ShowS
takeUntil String
end String
text =
    case String -> ShowS
forall {a}. Eq a => [a] -> [a] -> [a]
dropUntil String
end String
text of
        [] -> String
text
        String
rest -> Int -> ShowS
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
text Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
rest) String
text
  where
    dropUntil :: [a] -> [a] -> [a]
dropUntil [a]
_ [] = []
    dropUntil [a]
m s :: [a]
s@(a
_ : [a]
cs)
        | [a]
m [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [a]
s = [a]
s
        | Bool
otherwise = [a] -> [a] -> [a]
dropUntil [a]
m [a]
cs

{- | Text up to the nearest of several end markers; the whole text
when none occurs.
-}
takeUntilAny :: [String] -> String -> String
takeUntilAny :: [String] -> ShowS
takeUntilAny [String]
ends String
text =
    case (String -> Int) -> [String] -> [String]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String -> ShowS
takeUntil String
e String
text | String
e <- [String]
ends, String
e String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
text] of
        [] -> String
text
        (String
shortest : [String]
_) -> String
shortest

{- | The marker the wrong-reason control matches refusals against: by
construction no node reason can contain it, so a matched reason can
never close a row and the control must fail.
-}
wrongReasonMarker :: String
wrongReasonMarker :: String
wrongReasonMarker =
    String
"wrong-reason-control marker that no node reason can ever contain"

-- ====================================================================
-- Refusal receipts: who writes, and who must never overwrite (A-002)
--
-- The empty-fold/surplus-fold-actions/request-value-and-refund-routing defect: a refused CONTROL submitted through the
-- same helper as a refusal ROW wrote its refusal under the row's id,
-- replacing the row's own held receipt in every receipts directory.
-- The receipts then asserted three held rows were refused — the exact
-- opposite of their executed findings. historical-owner-change's receipt survived only
-- because its control was retired before the final runs, which is
-- what isolated the cause.

{- | Whose refusal is being attributed: a refusal ROW's receipt IS
the row outcome and is written; a refused CONTROL's outcome is
run-log evidence under its own identity and must never overwrite
the row's receipt.
-}
data RefusalRole = RefusalRow | RefusalControl
    deriving stock (Int -> RefusalRole -> ShowS
[RefusalRole] -> ShowS
RefusalRole -> String
(Int -> RefusalRole -> ShowS)
-> (RefusalRole -> String)
-> ([RefusalRole] -> ShowS)
-> Show RefusalRole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefusalRole -> ShowS
showsPrec :: Int -> RefusalRole -> ShowS
$cshow :: RefusalRole -> String
show :: RefusalRole -> String
$cshowList :: [RefusalRole] -> ShowS
showList :: [RefusalRole] -> ShowS
Show, RefusalRole -> RefusalRole -> Bool
(RefusalRole -> RefusalRole -> Bool)
-> (RefusalRole -> RefusalRole -> Bool) -> Eq RefusalRole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefusalRole -> RefusalRole -> Bool
== :: RefusalRole -> RefusalRole -> Bool
$c/= :: RefusalRole -> RefusalRole -> Bool
/= :: RefusalRole -> RefusalRole -> Bool
Eq)

{- | The receipt policy per role. A control keeps its evidence in the
run log and its failures loud — an accepted control fails the run as
a FINDING and a refusal that does not attribute fails the run naming
the mismatch — so writing nothing leaves it unable to pass silently,
while the row's held verdict survives its own control.
-}
refusalWritesReceipt :: RefusalRole -> Bool
refusalWritesReceipt :: RefusalRole -> Bool
refusalWritesReceipt RefusalRole
role = case RefusalRole
role of
    RefusalRole
RefusalRow -> Bool
True
    -- The repair (A-002): a control's refusal is run-log evidence with
    -- its own identity. It cannot silently pass — an accepted control
    -- fails the run as a FINDING and a refusal that does not attribute
    -- fails the run naming the mismatch — so writing nothing leaves it
    -- fully evidenced while the row's held verdict survives its own
    -- control. Spec: RefusalSpec, "receipt policy (A-002)".
    RefusalRole
RefusalControl -> Bool
False

{- | What the traced replay of a refused transaction established: the reason
it admitted for the attributed script, when every purpose of that script
admitted the same one; the replay of each failing purpose; and the traced
build those reasons rely on.
-}
data TracedRefusal = TracedRefusal
    { TracedRefusal -> Maybe Text
tracedAdmitted :: Maybe T.Text
    , TracedRefusal -> [ReplayEvidence]
tracedReplay :: [ReplayEvidence]
    , TracedRefusal -> Maybe ReplayCorrespondence
tracedCorrespondence :: Maybe ReplayCorrespondence
    }
    deriving stock (Int -> TracedRefusal -> ShowS
[TracedRefusal] -> ShowS
TracedRefusal -> String
(Int -> TracedRefusal -> ShowS)
-> (TracedRefusal -> String)
-> ([TracedRefusal] -> ShowS)
-> Show TracedRefusal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TracedRefusal -> ShowS
showsPrec :: Int -> TracedRefusal -> ShowS
$cshow :: TracedRefusal -> String
show :: TracedRefusal -> String
$cshowList :: [TracedRefusal] -> ShowS
showList :: [TracedRefusal] -> ShowS
Show, TracedRefusal -> TracedRefusal -> Bool
(TracedRefusal -> TracedRefusal -> Bool)
-> (TracedRefusal -> TracedRefusal -> Bool) -> Eq TracedRefusal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TracedRefusal -> TracedRefusal -> Bool
== :: TracedRefusal -> TracedRefusal -> Bool
$c/= :: TracedRefusal -> TracedRefusal -> Bool
/= :: TracedRefusal -> TracedRefusal -> Bool
Eq)

-- | A refusal no traced replay recorded.
untraced :: TracedRefusal
untraced :: TracedRefusal
untraced = Maybe Text
-> [ReplayEvidence] -> Maybe ReplayCorrespondence -> TracedRefusal
TracedRefusal Maybe Text
forall a. Maybe a
Nothing [] Maybe ReplayCorrespondence
forall a. Maybe a
Nothing

{- | Attribute a node-submit refusal and, when the role's policy
writes, record the refused receipt under the row's id. Returns the
attribution mismatch for the caller to fail on loudly — this function
never swallows a refusal that does not attribute, and a control here
can never silently pass: acceptance and wrong-reason both fail the
run upstream of this call. The receipt carries the trimmed reason
(volume trimmed, never the script identities), the submitted
transaction's id under @rejected@, and the @node-submit@ venue.
-}
attributeRefusalReceipt
    :: RefusalRole
    -> FilePath
    -- ^ receipts directory (only touched when the policy writes)
    -> String
    -- ^ row id
    -> Verdict
    -- ^ verdict the receipt would carry
    -> String
    -- ^ attributed script label
    -> String
    -- ^ expected marker (applied script hash hex)
    -> String
    -- ^ the node's refusal reason, verbatim
    -> String
    -- ^ the submitted transaction's id
    -> String
    -- ^ base commit
    -> Bool
    -- ^ dirty tree flag
    -> String
    -- ^ node identity
    -> String
    -- ^ blueprint identity
    -> TracedRefusal
    -- ^ what the traced replay of the refused transaction established
    -> IO (Either RefusalMismatch ())
attributeRefusalReceipt :: RefusalRole
-> String
-> String
-> Verdict
-> String
-> String
-> String
-> String
-> String
-> Bool
-> String
-> String
-> TracedRefusal
-> IO (Either RefusalMismatch ())
attributeRefusalReceipt RefusalRole
role String
dir String
row Verdict
verdict String
script String
marker String
text String
rejectedTxid String
base Bool
dirty String
node String
blueprint TracedRefusal
traced =
    case String -> String -> Either RefusalMismatch ()
matchRefusal String
marker String
text of
        Left RefusalMismatch
m -> Either RefusalMismatch () -> IO (Either RefusalMismatch ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RefusalMismatch -> Either RefusalMismatch ()
forall a b. a -> Either a b
Left RefusalMismatch
m)
        Right () -> do
            let recorded :: String
recorded = String -> ShowS
recordedReason String
text String
marker
                admitted :: Maybe Text
admitted = TracedRefusal -> Maybe Text
tracedAdmitted TracedRefusal
traced
                replay :: Maybe [ReplayEvidence]
replay = case TracedRefusal -> [ReplayEvidence]
tracedReplay TracedRefusal
traced of
                    [] -> Maybe [ReplayEvidence]
forall a. Maybe a
Nothing
                    [ReplayEvidence]
entries -> [ReplayEvidence] -> Maybe [ReplayEvidence]
forall a. a -> Maybe a
Just [ReplayEvidence]
entries
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RefusalRole -> Bool
refusalWritesReceipt RefusalRole
role) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> Receipt -> IO ()
writeReceiptFile
                    String
dir
                    Receipt
                        { receiptRow :: Text
receiptRow = String -> Text
T.pack String
row
                        , receiptOutcome :: Outcome
receiptOutcome = Outcome
Refused
                        , receiptVerdict :: Verdict
receiptVerdict = Verdict
verdict
                        , receiptTransactions :: [Text]
receiptTransactions = []
                        , receiptRefusal :: Maybe RefusalInfo
receiptRefusal =
                            RefusalInfo -> Maybe RefusalInfo
forall a. a -> Maybe a
Just
                                ( RefusalInfo
                                    { refusalScript :: Text
refusalScript = String -> Text
T.pack String
script
                                    , refusalReason :: Text
refusalReason = String -> Text
T.pack String
recorded
                                    , refusalPhase :: Text
refusalPhase = Text
"phase-2"
                                    , refusalHashes :: [Text]
refusalHashes =
                                        (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack (String -> [String]
refusalScriptHashes String
text)
                                    , refusalBranch :: Maybe Text
refusalBranch = Maybe Text
admitted
                                    , refusalReplay :: Maybe [ReplayEvidence]
refusalReplay = Maybe [ReplayEvidence]
replay
                                    , refusalLimit :: Maybe Text
refusalLimit = case Maybe Text
admitted of
                                        Just Text
_ -> Maybe Text
forall a. Maybe a
Nothing
                                        Maybe Text
Nothing ->
                                            Text -> Maybe Text
forall a. a -> Maybe a
Just
                                                Text
"no named validator branch in this compiled trace; attribution is script hash plus phase-2 only"
                                    }
                                )
                        , receiptMem :: Maybe Integer
receiptMem = Maybe Integer
forall a. Maybe a
Nothing
                        , receiptCpu :: Maybe Integer
receiptCpu = Maybe Integer
forall a. Maybe a
Nothing
                        , receiptTxSize :: Maybe Integer
receiptTxSize = Maybe Integer
forall a. Maybe a
Nothing
                        , receiptBase :: Text
receiptBase = String -> Text
T.pack String
base
                        , receiptNode :: Text
receiptNode = String -> Text
T.pack String
node
                        , receiptBlueprint :: Text
receiptBlueprint = String -> Text
T.pack String
blueprint
                        , receiptVenue :: Text
receiptVenue = Text
"node-submit"
                        , receiptRejected :: Maybe Text
receiptRejected = Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
T.pack String
rejectedTxid)
                        , receiptDirty :: Bool
receiptDirty = Bool
dirty
                        , receiptPartial :: Maybe PartialInfo
receiptPartial = Maybe PartialInfo
forall a. Maybe a
Nothing
                        , receiptDerivation :: Maybe [DerivationEvidence]
receiptDerivation = Maybe [DerivationEvidence]
forall a. Maybe a
Nothing
                        , receiptSteps :: Maybe [Value]
receiptSteps = Maybe [Value]
forall a. Maybe a
Nothing
                        , receiptReplayCorrespondence :: Maybe ReplayCorrespondence
receiptReplayCorrespondence =
                            TracedRefusal -> Maybe ReplayCorrespondence
tracedCorrespondence TracedRefusal
traced Maybe ReplayCorrespondence
-> Maybe [ReplayEvidence] -> Maybe ReplayCorrespondence
forall a b. Maybe a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Maybe [ReplayEvidence]
replay
                        }
            Either RefusalMismatch () -> IO (Either RefusalMismatch ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either RefusalMismatch ()
forall a b. b -> Either a b
Right ())

{- | The reason a receipt records: trimmed to what attributes, but
kept wide enough that the expected marker survives — a trimmer that
keeps one hash can drop ours when several failed. This is the
Run.hs policy moved beside the write it feeds.
-}
recordedReason :: String -> String -> String
recordedReason :: String -> ShowS
recordedReason String
text String
marker =
    let trimmed :: String
trimmed = ShowS
trimRefusal String
text
    in  if String
marker String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
trimmed then String
trimmed else Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
2000 String
text