{-# LANGUAGE LambdaCase #-}

{- |
Module      : Conformance.Replay
Description : What a traced replay of a live refusal admits as its reason
License     : Apache-2.0

A live phase-2 refusal carries no reason: the deployed validators are built
without traces. The runner replays the refused transaction's failing script
twice on the arguments the ledger built for it — the deployed bytes under the
transaction's declared units, then the traced bytes of the same source with
the same parameters under the protocol maximum — and this module decides what
those two runs establish.

A reason is admitted only when both runs fail as a validator and the traced
run leaves exactly one user-defined trace; that line, verbatim, is the reason.
Every other result is an unobserved reason with its cause, and every cause is
its own value. A reason is compared with the model's only once admitted.

Pure: the runs arrive as data. Capturing and evaluating belong to the
runner's replay module, @Conformance.Run.Replay@.
-}
module Conformance.Replay
    ( -- * Runs
      RunOutcome (..)
    , ReplayRun (..)

      -- * Classes
    , UnobservedCause (..)
    , causeName
    , ReplayClass (..)
    , admitReason
    , userTraces
    , ScriptFamily (..)
    , identifyScript

      -- * Comparison
    , ReasonComparison (..)
    , compareReason
    , stepComparison
    , comparisonName
    , admittedFor

      -- * Evidence
    , PurposeReplay (..)
    , acceptingControlGaps
    , TracedProvenance (..)
    , toolchainCause
    , captureIdOf

      -- * Receipt evidence
    , ReplayEvidence (..)
    , rejectionEvidence
    , ReplayCorrespondence (..)
    , correspondenceOf
    ) where

import Crypto.Hash qualified as Hash
import Data.Aeson
    ( FromJSON (..)
    , ToJSON (..)
    , Value (..)
    , object
    , withObject
    , (.:)
    , (.:?)
    , (.=)
    )
import Data.Aeson.KeyMap qualified as KM
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.Foldable (toList)
import Data.List (nub, sortOn)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE

-- | How one evaluation of one script on one purpose's arguments ended.
data RunOutcome
    = -- | the script returned
      Succeeded
    | -- | the script failed: an @error@, a failed builtin, a non-unit result
      ValidatorFailure
    | -- | the budget ran out before the script finished
      BudgetExhausted
    | -- | the evaluator could not run the script at all
      EvaluationError Text
    deriving stock (Int -> RunOutcome -> ShowS
[RunOutcome] -> ShowS
RunOutcome -> FilePath
(Int -> RunOutcome -> ShowS)
-> (RunOutcome -> FilePath)
-> ([RunOutcome] -> ShowS)
-> Show RunOutcome
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunOutcome -> ShowS
showsPrec :: Int -> RunOutcome -> ShowS
$cshow :: RunOutcome -> FilePath
show :: RunOutcome -> FilePath
$cshowList :: [RunOutcome] -> ShowS
showList :: [RunOutcome] -> ShowS
Show, RunOutcome -> RunOutcome -> Bool
(RunOutcome -> RunOutcome -> Bool)
-> (RunOutcome -> RunOutcome -> Bool) -> Eq RunOutcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RunOutcome -> RunOutcome -> Bool
== :: RunOutcome -> RunOutcome -> Bool
$c/= :: RunOutcome -> RunOutcome -> Bool
/= :: RunOutcome -> RunOutcome -> Bool
Eq)

-- | One evaluation: which bytes, under which limit, using what, how it ended.
data ReplayRun = ReplayRun
    { ReplayRun -> Text
runBytesHash :: Text
    -- ^ hash of the script bytes evaluated
    , ReplayRun -> (Integer, Integer)
runBudgetLimit :: (Integer, Integer)
    -- ^ memory and steps the evaluation was allowed
    , ReplayRun -> Maybe (Integer, Integer)
runBudgetUsed :: Maybe (Integer, Integer)
    -- ^ what a finished evaluation spent; 'Nothing' when it did not finish
    , ReplayRun -> RunOutcome
runOutcome :: RunOutcome
    , ReplayRun -> [Text]
runLogs :: [Text]
    -- ^ the evaluation's log lines, verbatim
    }
    deriving stock (Int -> ReplayRun -> ShowS
[ReplayRun] -> ShowS
ReplayRun -> FilePath
(Int -> ReplayRun -> ShowS)
-> (ReplayRun -> FilePath)
-> ([ReplayRun] -> ShowS)
-> Show ReplayRun
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReplayRun -> ShowS
showsPrec :: Int -> ReplayRun -> ShowS
$cshow :: ReplayRun -> FilePath
show :: ReplayRun -> FilePath
$cshowList :: [ReplayRun] -> ShowS
showList :: [ReplayRun] -> ShowS
Show, ReplayRun -> ReplayRun -> Bool
(ReplayRun -> ReplayRun -> Bool)
-> (ReplayRun -> ReplayRun -> Bool) -> Eq ReplayRun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReplayRun -> ReplayRun -> Bool
== :: ReplayRun -> ReplayRun -> Bool
$c/= :: ReplayRun -> ReplayRun -> Bool
/= :: ReplayRun -> ReplayRun -> Bool
Eq)

-- | Why a replay admits no reason. Each is distinct; none stands for another.
data UnobservedCause
    = -- | the capture does not resolve every output the transaction names
      CaptureIncomplete
    | -- | the ledger's arguments for the failing purpose could not be built
      ContextUnavailable
    | -- | the deployed blueprint is not the one the traced build corresponds to
      ToolchainMismatch
    | -- | the failing script's family is identified, but the replay traces none of it
      NoReplayRoute
    | -- | the family is identified by the capture; its applications do not reproduce the hash
      ParametersMismatch
    | -- | no family is identified and no application is claimed
      UnidentifiedScript
    | DeployedSucceeds
    | DeployedBudget
    | TracedSucceeds
    | TracedBudget
    | -- | the traced run failed without a user-defined trace
      NoUserTrace
    | -- | the traced run failed with more than one user-defined trace
      SeveralUserTraces
    | -- | the node rejected the transaction before any script ran
      Phase1
    | -- | the run could not reach the evaluation
      SetupFailure
    | Timeout
    | ClientException
    | -- | the evaluator itself failed, on either run
      EvaluatorFailed
    deriving stock (Int -> UnobservedCause -> ShowS
[UnobservedCause] -> ShowS
UnobservedCause -> FilePath
(Int -> UnobservedCause -> ShowS)
-> (UnobservedCause -> FilePath)
-> ([UnobservedCause] -> ShowS)
-> Show UnobservedCause
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnobservedCause -> ShowS
showsPrec :: Int -> UnobservedCause -> ShowS
$cshow :: UnobservedCause -> FilePath
show :: UnobservedCause -> FilePath
$cshowList :: [UnobservedCause] -> ShowS
showList :: [UnobservedCause] -> ShowS
Show, UnobservedCause -> UnobservedCause -> Bool
(UnobservedCause -> UnobservedCause -> Bool)
-> (UnobservedCause -> UnobservedCause -> Bool)
-> Eq UnobservedCause
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnobservedCause -> UnobservedCause -> Bool
== :: UnobservedCause -> UnobservedCause -> Bool
$c/= :: UnobservedCause -> UnobservedCause -> Bool
/= :: UnobservedCause -> UnobservedCause -> Bool
Eq, Eq UnobservedCause
Eq UnobservedCause =>
(UnobservedCause -> UnobservedCause -> Ordering)
-> (UnobservedCause -> UnobservedCause -> Bool)
-> (UnobservedCause -> UnobservedCause -> Bool)
-> (UnobservedCause -> UnobservedCause -> Bool)
-> (UnobservedCause -> UnobservedCause -> Bool)
-> (UnobservedCause -> UnobservedCause -> UnobservedCause)
-> (UnobservedCause -> UnobservedCause -> UnobservedCause)
-> Ord UnobservedCause
UnobservedCause -> UnobservedCause -> Bool
UnobservedCause -> UnobservedCause -> Ordering
UnobservedCause -> UnobservedCause -> UnobservedCause
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 :: UnobservedCause -> UnobservedCause -> Ordering
compare :: UnobservedCause -> UnobservedCause -> Ordering
$c< :: UnobservedCause -> UnobservedCause -> Bool
< :: UnobservedCause -> UnobservedCause -> Bool
$c<= :: UnobservedCause -> UnobservedCause -> Bool
<= :: UnobservedCause -> UnobservedCause -> Bool
$c> :: UnobservedCause -> UnobservedCause -> Bool
> :: UnobservedCause -> UnobservedCause -> Bool
$c>= :: UnobservedCause -> UnobservedCause -> Bool
>= :: UnobservedCause -> UnobservedCause -> Bool
$cmax :: UnobservedCause -> UnobservedCause -> UnobservedCause
max :: UnobservedCause -> UnobservedCause -> UnobservedCause
$cmin :: UnobservedCause -> UnobservedCause -> UnobservedCause
min :: UnobservedCause -> UnobservedCause -> UnobservedCause
Ord, Int -> UnobservedCause
UnobservedCause -> Int
UnobservedCause -> [UnobservedCause]
UnobservedCause -> UnobservedCause
UnobservedCause -> UnobservedCause -> [UnobservedCause]
UnobservedCause
-> UnobservedCause -> UnobservedCause -> [UnobservedCause]
(UnobservedCause -> UnobservedCause)
-> (UnobservedCause -> UnobservedCause)
-> (Int -> UnobservedCause)
-> (UnobservedCause -> Int)
-> (UnobservedCause -> [UnobservedCause])
-> (UnobservedCause -> UnobservedCause -> [UnobservedCause])
-> (UnobservedCause -> UnobservedCause -> [UnobservedCause])
-> (UnobservedCause
    -> UnobservedCause -> UnobservedCause -> [UnobservedCause])
-> Enum UnobservedCause
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 :: UnobservedCause -> UnobservedCause
succ :: UnobservedCause -> UnobservedCause
$cpred :: UnobservedCause -> UnobservedCause
pred :: UnobservedCause -> UnobservedCause
$ctoEnum :: Int -> UnobservedCause
toEnum :: Int -> UnobservedCause
$cfromEnum :: UnobservedCause -> Int
fromEnum :: UnobservedCause -> Int
$cenumFrom :: UnobservedCause -> [UnobservedCause]
enumFrom :: UnobservedCause -> [UnobservedCause]
$cenumFromThen :: UnobservedCause -> UnobservedCause -> [UnobservedCause]
enumFromThen :: UnobservedCause -> UnobservedCause -> [UnobservedCause]
$cenumFromTo :: UnobservedCause -> UnobservedCause -> [UnobservedCause]
enumFromTo :: UnobservedCause -> UnobservedCause -> [UnobservedCause]
$cenumFromThenTo :: UnobservedCause
-> UnobservedCause -> UnobservedCause -> [UnobservedCause]
enumFromThenTo :: UnobservedCause
-> UnobservedCause -> UnobservedCause -> [UnobservedCause]
Enum, UnobservedCause
UnobservedCause -> UnobservedCause -> Bounded UnobservedCause
forall a. a -> a -> Bounded a
$cminBound :: UnobservedCause
minBound :: UnobservedCause
$cmaxBound :: UnobservedCause
maxBound :: UnobservedCause
Bounded)

-- | The cause as the replay evidence spells it.
causeName :: UnobservedCause -> Text
causeName :: UnobservedCause -> Text
causeName = \case
    UnobservedCause
CaptureIncomplete -> Text
"capture-incomplete"
    UnobservedCause
ContextUnavailable -> Text
"context-unavailable"
    UnobservedCause
ToolchainMismatch -> Text
"toolchain-mismatch"
    UnobservedCause
NoReplayRoute -> Text
"no-replay-route"
    UnobservedCause
ParametersMismatch -> Text
"parameters-mismatch"
    UnobservedCause
UnidentifiedScript -> Text
"unidentified-script"
    UnobservedCause
DeployedSucceeds -> Text
"deployed-succeeds"
    UnobservedCause
DeployedBudget -> Text
"deployed-budget"
    UnobservedCause
TracedSucceeds -> Text
"traced-succeeds"
    UnobservedCause
TracedBudget -> Text
"traced-budget"
    UnobservedCause
NoUserTrace -> Text
"no-user-trace"
    UnobservedCause
SeveralUserTraces -> Text
"several-user-traces"
    UnobservedCause
Phase1 -> Text
"phase-1"
    UnobservedCause
SetupFailure -> Text
"setup-failure"
    UnobservedCause
Timeout -> Text
"timeout"
    UnobservedCause
ClientException -> Text
"client-exception"
    UnobservedCause
EvaluatorFailed -> Text
"evaluation-error"

-- | What a replay establishes about the chain-side reason.
data ReplayClass
    = Admitted Text
    | Unobserved UnobservedCause
    deriving stock (Int -> ReplayClass -> ShowS
[ReplayClass] -> ShowS
ReplayClass -> FilePath
(Int -> ReplayClass -> ShowS)
-> (ReplayClass -> FilePath)
-> ([ReplayClass] -> ShowS)
-> Show ReplayClass
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReplayClass -> ShowS
showsPrec :: Int -> ReplayClass -> ShowS
$cshow :: ReplayClass -> FilePath
show :: ReplayClass -> FilePath
$cshowList :: [ReplayClass] -> ShowS
showList :: [ReplayClass] -> ShowS
Show, ReplayClass -> ReplayClass -> Bool
(ReplayClass -> ReplayClass -> Bool)
-> (ReplayClass -> ReplayClass -> Bool) -> Eq ReplayClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReplayClass -> ReplayClass -> Bool
== :: ReplayClass -> ReplayClass -> Bool
$c/= :: ReplayClass -> ReplayClass -> Bool
/= :: ReplayClass -> ReplayClass -> Bool
Eq)

instance ToJSON ReplayClass where
    toJSON :: ReplayClass -> Value
toJSON (Admitted Text
reason) = [Pair] -> Value
object [Key
"admitted" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
reason]
    toJSON (Unobserved UnobservedCause
cause) = [Pair] -> Value
object [Key
"unobserved" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UnobservedCause -> Text
causeName UnobservedCause
cause]

{- | Decide what the deployed run and the traced run admit. An earlier cause
(capture, toolchain, parameters, or the run never reaching evaluation) wins.
-}
admitReason
    :: ReplayRun -> ReplayRun -> Maybe UnobservedCause -> ReplayClass
admitReason :: ReplayRun -> ReplayRun -> Maybe UnobservedCause -> ReplayClass
admitReason ReplayRun
deployed ReplayRun
traced = \case
    Just UnobservedCause
cause -> UnobservedCause -> ReplayClass
Unobserved UnobservedCause
cause
    Maybe UnobservedCause
Nothing -> case (ReplayRun -> RunOutcome
runOutcome ReplayRun
deployed, ReplayRun -> RunOutcome
runOutcome ReplayRun
traced) of
        (RunOutcome
Succeeded, RunOutcome
_) -> UnobservedCause -> ReplayClass
Unobserved UnobservedCause
DeployedSucceeds
        (RunOutcome
BudgetExhausted, RunOutcome
_) -> UnobservedCause -> ReplayClass
Unobserved UnobservedCause
DeployedBudget
        (EvaluationError Text
_, RunOutcome
_) -> UnobservedCause -> ReplayClass
Unobserved UnobservedCause
EvaluatorFailed
        (RunOutcome
ValidatorFailure, RunOutcome
Succeeded) -> UnobservedCause -> ReplayClass
Unobserved UnobservedCause
TracedSucceeds
        (RunOutcome
ValidatorFailure, RunOutcome
BudgetExhausted) -> UnobservedCause -> ReplayClass
Unobserved UnobservedCause
TracedBudget
        (RunOutcome
ValidatorFailure, EvaluationError Text
_) -> UnobservedCause -> ReplayClass
Unobserved UnobservedCause
EvaluatorFailed
        (RunOutcome
ValidatorFailure, RunOutcome
ValidatorFailure) ->
            case [Text] -> [Text]
userTraces (ReplayRun -> [Text]
runLogs ReplayRun
traced) of
                [] -> UnobservedCause -> ReplayClass
Unobserved UnobservedCause
NoUserTrace
                [Text
reason] -> Text -> ReplayClass
Admitted Text
reason
                [Text]
_ -> UnobservedCause -> ReplayClass
Unobserved UnobservedCause
SeveralUserTraces

{- | The user-defined lines of an evaluation log. The traced build keeps only
user-defined traces, so every non-blank line is one.
-}
userTraces :: [Text] -> [Text]
userTraces :: [Text] -> [Text]
userTraces = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip)

-- | A refused step's chain-side reason against the model's.
data ReasonComparison
    = Agrees
    | Differs {ReasonComparison -> Text
chainReason :: Text, ReasonComparison -> Text
leanReason :: Text}
    | Uncompared UnobservedCause
    deriving stock (Int -> ReasonComparison -> ShowS
[ReasonComparison] -> ShowS
ReasonComparison -> FilePath
(Int -> ReasonComparison -> ShowS)
-> (ReasonComparison -> FilePath)
-> ([ReasonComparison] -> ShowS)
-> Show ReasonComparison
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReasonComparison -> ShowS
showsPrec :: Int -> ReasonComparison -> ShowS
$cshow :: ReasonComparison -> FilePath
show :: ReasonComparison -> FilePath
$cshowList :: [ReasonComparison] -> ShowS
showList :: [ReasonComparison] -> ShowS
Show, ReasonComparison -> ReasonComparison -> Bool
(ReasonComparison -> ReasonComparison -> Bool)
-> (ReasonComparison -> ReasonComparison -> Bool)
-> Eq ReasonComparison
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReasonComparison -> ReasonComparison -> Bool
== :: ReasonComparison -> ReasonComparison -> Bool
$c/= :: ReasonComparison -> ReasonComparison -> Bool
/= :: ReasonComparison -> ReasonComparison -> Bool
Eq)

-- | Compare an admitted reason with Lean's; an unobserved one is not compared.
compareReason :: Text -> ReplayClass -> ReasonComparison
compareReason :: Text -> ReplayClass -> ReasonComparison
compareReason Text
lean = \case
    Admitted Text
chain
        | Text
chain Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
lean -> ReasonComparison
Agrees
        | Bool
otherwise -> Differs{chainReason :: Text
chainReason = Text
chain, leanReason :: Text
leanReason = Text
lean}
    Unobserved UnobservedCause
cause -> UnobservedCause -> ReasonComparison
Uncompared UnobservedCause
cause

-- | One failing purpose of one rejected transaction, and its two runs.
data PurposeReplay = PurposeReplay
    { PurposeReplay -> Text
prPurpose :: Text
    -- ^ the purpose and its redeemer index, as the ledger names it
    , PurposeReplay -> Text
prDeployedHash :: Text
    -- ^ the failing hash the node reported
    , PurposeReplay -> Maybe Text
prTracedHash :: Maybe Text
    -- ^ the traced code's hash under the same parameters, once applied
    , PurposeReplay -> Maybe ReplayRun
prDeployed :: Maybe ReplayRun
    , PurposeReplay -> Maybe ReplayRun
prTraced :: Maybe ReplayRun
    , PurposeReplay -> ReplayClass
prClass :: ReplayClass
    }
    deriving stock (Int -> PurposeReplay -> ShowS
[PurposeReplay] -> ShowS
PurposeReplay -> FilePath
(Int -> PurposeReplay -> ShowS)
-> (PurposeReplay -> FilePath)
-> ([PurposeReplay] -> ShowS)
-> Show PurposeReplay
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PurposeReplay -> ShowS
showsPrec :: Int -> PurposeReplay -> ShowS
$cshow :: PurposeReplay -> FilePath
show :: PurposeReplay -> FilePath
$cshowList :: [PurposeReplay] -> ShowS
showList :: [PurposeReplay] -> ShowS
Show, PurposeReplay -> PurposeReplay -> Bool
(PurposeReplay -> PurposeReplay -> Bool)
-> (PurposeReplay -> PurposeReplay -> Bool) -> Eq PurposeReplay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PurposeReplay -> PurposeReplay -> Bool
== :: PurposeReplay -> PurposeReplay -> Bool
$c/= :: PurposeReplay -> PurposeReplay -> Bool
/= :: PurposeReplay -> PurposeReplay -> Bool
Eq)

-- | The traced build's provenance, as the flake writes it beside it.
data TracedProvenance = TracedProvenance
    { TracedProvenance -> Text
tpSource :: Text
    , TracedProvenance -> Text
tpCompiler :: Text
    , TracedProvenance -> Text
tpFlags :: Text
    , TracedProvenance -> Map Text Text
tpUntracedHashes :: Map Text Text
    }
    deriving stock (Int -> TracedProvenance -> ShowS
[TracedProvenance] -> ShowS
TracedProvenance -> FilePath
(Int -> TracedProvenance -> ShowS)
-> (TracedProvenance -> FilePath)
-> ([TracedProvenance] -> ShowS)
-> Show TracedProvenance
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TracedProvenance -> ShowS
showsPrec :: Int -> TracedProvenance -> ShowS
$cshow :: TracedProvenance -> FilePath
show :: TracedProvenance -> FilePath
$cshowList :: [TracedProvenance] -> ShowS
showList :: [TracedProvenance] -> ShowS
Show, TracedProvenance -> TracedProvenance -> Bool
(TracedProvenance -> TracedProvenance -> Bool)
-> (TracedProvenance -> TracedProvenance -> Bool)
-> Eq TracedProvenance
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TracedProvenance -> TracedProvenance -> Bool
== :: TracedProvenance -> TracedProvenance -> Bool
$c/= :: TracedProvenance -> TracedProvenance -> Bool
/= :: TracedProvenance -> TracedProvenance -> Bool
Eq)

instance FromJSON TracedProvenance where
    parseJSON :: Value -> Parser TracedProvenance
parseJSON = FilePath
-> (Object -> Parser TracedProvenance)
-> Value
-> Parser TracedProvenance
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"TracedProvenance" ((Object -> Parser TracedProvenance)
 -> Value -> Parser TracedProvenance)
-> (Object -> Parser TracedProvenance)
-> Value
-> Parser TracedProvenance
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text -> Text -> Text -> Map Text Text -> TracedProvenance
TracedProvenance
            (Text -> Text -> Text -> Map Text Text -> TracedProvenance)
-> Parser Text
-> Parser (Text -> Text -> Map Text Text -> TracedProvenance)
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
"source"
            Parser (Text -> Text -> Map Text Text -> TracedProvenance)
-> Parser Text
-> Parser (Text -> Map Text Text -> TracedProvenance)
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
"compiler"
            Parser (Text -> Map Text Text -> TracedProvenance)
-> Parser Text -> Parser (Map Text Text -> TracedProvenance)
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
"flags"
            Parser (Map Text Text -> TracedProvenance)
-> Parser (Map Text Text) -> Parser TracedProvenance
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 (Map Text Text)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"untracedHashes"

{- | The identity of a capture: SHA-256 over each file's canonical name and
content hash, in name order, so the order the files were written in does not
move it.
-}
captureIdOf :: [(FilePath, ByteString)] -> Text
captureIdOf :: [(FilePath, ByteString)] -> Text
captureIdOf [(FilePath, ByteString)]
files =
    ByteString -> Text
sha256Hex
        ( [ByteString] -> ByteString
BS.concat
            [ FilePath -> ByteString
BS8.pack FilePath
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\0" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
TE.encodeUtf8 (ByteString -> Text
sha256Hex ByteString
content) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
            | (FilePath
name, ByteString
content) <- ((FilePath, ByteString) -> FilePath)
-> [(FilePath, ByteString)] -> [(FilePath, ByteString)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FilePath, ByteString) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, ByteString)]
files
            ]
        )

sha256Hex :: ByteString -> Text
sha256Hex :: ByteString -> Text
sha256Hex = FilePath -> Text
T.pack (FilePath -> Text)
-> (ByteString -> FilePath) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> FilePath
forall a. Show a => a -> FilePath
show (Digest SHA256 -> FilePath)
-> (ByteString -> Digest SHA256) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA256 -> ByteString -> Digest SHA256
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
Hash.hashWith SHA256
Hash.SHA256

{- | 'ToolchainMismatch' unless the deployed blueprint's validators are
exactly the ones the traced build's untraced twin produced, hash for hash.
-}
toolchainCause
    :: TracedProvenance -> Map Text Text -> Maybe UnobservedCause
toolchainCause :: TracedProvenance -> Map Text Text -> Maybe UnobservedCause
toolchainCause TracedProvenance
provenance Map Text Text
deployed
    | TracedProvenance -> Map Text Text
tpUntracedHashes TracedProvenance
provenance Map Text Text -> Map Text Text -> Bool
forall a. Eq a => a -> a -> Bool
== Map Text Text
deployed = Maybe UnobservedCause
forall a. Maybe a
Nothing
    | Bool
otherwise = UnobservedCause -> Maybe UnobservedCause
forall a. a -> Maybe a
Just UnobservedCause
ToolchainMismatch

instance ToJSON RunOutcome where
    toJSON :: RunOutcome -> Value
toJSON = \case
        RunOutcome
Succeeded -> Value
"succeeded"
        RunOutcome
ValidatorFailure -> Value
"validator-failure"
        RunOutcome
BudgetExhausted -> Value
"budget-exhausted"
        EvaluationError Text
message -> [Pair] -> Value
object [Key
"evaluation-error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
message]

instance ToJSON ReplayRun where
    toJSON :: ReplayRun -> Value
toJSON ReplayRun
r =
        [Pair] -> Value
object
            [ Key
"bytesHash" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ReplayRun -> Text
runBytesHash ReplayRun
r
            , Key
"budgetLimit" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Integer, Integer) -> Value
forall {v} {v}. (ToJSON v, ToJSON v) => (v, v) -> Value
units (ReplayRun -> (Integer, Integer)
runBudgetLimit ReplayRun
r)
            , Key
"budgetUsed" Key -> Maybe Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ((Integer, Integer) -> Value)
-> Maybe (Integer, Integer) -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer, Integer) -> Value
forall {v} {v}. (ToJSON v, ToJSON v) => (v, v) -> Value
units (ReplayRun -> Maybe (Integer, Integer)
runBudgetUsed ReplayRun
r)
            , Key
"outcome" Key -> RunOutcome -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ReplayRun -> RunOutcome
runOutcome ReplayRun
r
            , Key
"logs" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ReplayRun -> [Text]
runLogs ReplayRun
r
            ]
      where
        units :: (v, v) -> Value
units (v
mem, v
steps) = [Pair] -> Value
object [Key
"mem" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
mem, Key
"steps" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
steps]

instance ToJSON PurposeReplay where
    toJSON :: PurposeReplay -> Value
toJSON PurposeReplay
p =
        [Pair] -> Value
object
            [ Key
"purpose" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PurposeReplay -> Text
prPurpose PurposeReplay
p
            , Key
"deployedHash" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PurposeReplay -> Text
prDeployedHash PurposeReplay
p
            , Key
"tracedHash" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PurposeReplay -> Maybe Text
prTracedHash PurposeReplay
p
            , Key
"deployed" Key -> Maybe ReplayRun -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PurposeReplay -> Maybe ReplayRun
prDeployed PurposeReplay
p
            , Key
"traced" Key -> Maybe ReplayRun -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PurposeReplay -> Maybe ReplayRun
prTraced PurposeReplay
p
            , Key
"class" Key -> ReplayClass -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PurposeReplay -> ReplayClass
prClass PurposeReplay
p
            ]

-- | A validator family the replay can recognise a failing hash by.
data ScriptFamily = ScriptFamily
    { ScriptFamily -> Text
sfTitle :: Text
    , ScriptFamily -> Bool
sfRouted :: Bool
    -- ^ whether the replay has a traced counterpart for it
    , ScriptFamily -> [Text]
sfCandidates :: [Text]
    -- ^ hashes of its untraced applications built from the capture
    }
    deriving stock (Int -> ScriptFamily -> ShowS
[ScriptFamily] -> ShowS
ScriptFamily -> FilePath
(Int -> ScriptFamily -> ShowS)
-> (ScriptFamily -> FilePath)
-> ([ScriptFamily] -> ShowS)
-> Show ScriptFamily
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptFamily -> ShowS
showsPrec :: Int -> ScriptFamily -> ShowS
$cshow :: ScriptFamily -> FilePath
show :: ScriptFamily -> FilePath
$cshowList :: [ScriptFamily] -> ShowS
showList :: [ScriptFamily] -> ShowS
Show, ScriptFamily -> ScriptFamily -> Bool
(ScriptFamily -> ScriptFamily -> Bool)
-> (ScriptFamily -> ScriptFamily -> Bool) -> Eq ScriptFamily
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptFamily -> ScriptFamily -> Bool
== :: ScriptFamily -> ScriptFamily -> Bool
$c/= :: ScriptFamily -> ScriptFamily -> Bool
/= :: ScriptFamily -> ScriptFamily -> Bool
Eq)

{- | Which family a failing hash belongs to: a routed family whose candidate
reproduces it is replayed; an unrouted one is 'NoReplayRoute'; a family the
capture records for the script (its role), none of whose candidates reproduce
it, is 'ParametersMismatch'; otherwise 'UnidentifiedScript'.
-}
identifyScript
    :: [ScriptFamily] -> Maybe Text -> Text -> Either UnobservedCause Text
identifyScript :: [ScriptFamily] -> Maybe Text -> Text -> Either UnobservedCause Text
identifyScript [ScriptFamily]
families Maybe Text
role Text
hash =
    case [ScriptFamily -> Text
sfTitle ScriptFamily
f | ScriptFamily
f <- [ScriptFamily]
families, ScriptFamily -> Bool
sfRouted ScriptFamily
f, Text
hash Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ScriptFamily -> [Text]
sfCandidates ScriptFamily
f] of
        Text
title : [Text]
_ -> Text -> Either UnobservedCause Text
forall a b. b -> Either a b
Right Text
title
        []
            | (ScriptFamily -> Bool) -> [ScriptFamily] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ScriptFamily
f -> Bool -> Bool
not (ScriptFamily -> Bool
sfRouted ScriptFamily
f) Bool -> Bool -> Bool
&& Text
hash Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ScriptFamily -> [Text]
sfCandidates ScriptFamily
f) [ScriptFamily]
families ->
                UnobservedCause -> Either UnobservedCause Text
forall a b. a -> Either a b
Left UnobservedCause
NoReplayRoute
            | Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ScriptFamily -> Text) -> [ScriptFamily] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ScriptFamily -> Text
sfTitle [ScriptFamily]
families) Maybe Text
role ->
                UnobservedCause -> Either UnobservedCause Text
forall a b. a -> Either a b
Left UnobservedCause
ParametersMismatch
            | Bool
otherwise -> UnobservedCause -> Either UnobservedCause Text
forall a b. a -> Either a b
Left UnobservedCause
UnidentifiedScript

{- | A refused step's comparison: the purposes of the script the step is
judged by (its marker hash) against Lean's reason. It agrees only when every
such purpose agrees; any purpose that differs makes it differ; otherwise it
is uncompared, with the first cause — or 'ContextUnavailable' when the
marker's script is not among the failing purposes at all.
-}
stepComparison
    :: Text -> Text -> [(Text, ReplayClass)] -> ReasonComparison
stepComparison :: Text -> Text -> [(Text, ReplayClass)] -> ReasonComparison
stepComparison Text
marker Text
lean [(Text, ReplayClass)]
purposes =
    case [Text -> ReplayClass -> ReasonComparison
compareReason Text
lean ReplayClass
cls | (Text
hash, ReplayClass
cls) <- [(Text, ReplayClass)]
purposes, Text
hash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
marker] of
        [] -> UnobservedCause -> ReasonComparison
Uncompared UnobservedCause
ContextUnavailable
        [ReasonComparison]
comparisons -> case [ReasonComparison
d | d :: ReasonComparison
d@Differs{} <- [ReasonComparison]
comparisons] of
            ReasonComparison
differing : [ReasonComparison]
_ -> ReasonComparison
differing
            [] -> case [UnobservedCause
cause | Uncompared UnobservedCause
cause <- [ReasonComparison]
comparisons] of
                UnobservedCause
cause : [UnobservedCause]
_ -> UnobservedCause -> ReasonComparison
Uncompared UnobservedCause
cause
                [] -> ReasonComparison
Agrees

-- | The comparison as the replay index spells it.
comparisonName :: ReasonComparison -> Text
comparisonName :: ReasonComparison -> Text
comparisonName = \case
    ReasonComparison
Agrees -> Text
"agrees"
    Differs{} -> Text
"differs"
    Uncompared UnobservedCause
_ -> Text
"uncompared"

{- | The reason the marker's script admitted, when every purpose of it admits
the same one.
-}
admittedFor :: Text -> [(Text, ReplayClass)] -> Maybe Text
admittedFor :: Text -> [(Text, ReplayClass)] -> Maybe Text
admittedFor Text
marker [(Text, ReplayClass)]
purposes =
    case [ReplayClass
cls | (Text
hash, ReplayClass
cls) <- [(Text, ReplayClass)]
purposes, Text
hash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
marker] of
        [] -> Maybe Text
forall a. Maybe a
Nothing
        [ReplayClass]
classes -> case [Text
reason | Admitted Text
reason <- [ReplayClass]
classes] of
            reasons :: [Text]
reasons@(Text
reason : [Text]
_)
                | [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
reasons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ReplayClass] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ReplayClass]
classes
                , (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
reason) [Text]
reasons ->
                    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
reason
            [Text]
_ -> Maybe Text
forall a. Maybe a
Nothing

{- | What the replay index lacks for FR-13: every script role a refusal names
(a validator title — a bare hash names no family a control could replay) needs
an @accepting-control@ entry in which that role's deployed and traced runs
both succeeded. One line per missing or failing role; none when complete.
-}
acceptingControlGaps :: [Value] -> [Text]
acceptingControlGaps :: [Value] -> [Text]
acceptingControlGaps [Value]
entries = (Text -> Maybe Text) -> [Text] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Text
gap [Text]
refusingRoles
  where
    field :: Key -> Value -> Maybe Value
field Key
name = \case
        Object Object
o -> Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
name Object
o
        Value
_ -> Maybe Value
forall a. Maybe a
Nothing
    kindIs :: Text -> Value -> Bool
kindIs Text
kind Value
entry = Key -> Value -> Maybe Value
field Key
"kind" Value
entry 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
kind)
    refusingRoles :: [Text]
refusingRoles =
        [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub
            [ Text
role
            | Value
entry <- [Value]
entries
            , Text -> Value -> Bool
kindIs Text
"refusal" Value
entry
            , Just (String Text
roles) <- [Key -> Value -> Maybe Value
field Key
"role" Value
entry]
            , Text
role <- HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"+" Text
roles
            , Text
"." Text -> Text -> Bool
`T.isInfixOf` Text
role
            ]
    controls :: [Value]
controls =
        [ Value
control
        | Value
entry <- [Value]
entries
        , Text -> Value -> Bool
kindIs Text
"accepting-control" Value
entry
        , Just (Array Array
listed) <- [Key -> Value -> Maybe Value
field Key
"controls" Value
entry]
        , Value
control <- Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
listed
        ]
    succeeded :: Key -> Value -> Bool
succeeded Key
run Value
control =
        (Key -> Value -> Maybe Value
field Key
run Value
control 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
"outcome") 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
"succeeded")
    gap :: Text -> Maybe Text
gap Text
role = case [Value
c | Value
c <- [Value]
controls, Key -> Value -> Maybe Value
field Key
"role" Value
c 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
role)] of
        [] -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
role Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": no accepting control")
        [Value]
ofRole
            | (Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Value
c -> Key -> Value -> Bool
succeeded Key
"deployed" Value
c Bool -> Bool -> Bool
&& Key -> Value -> Bool
succeeded Key
"traced" Value
c) [Value]
ofRole ->
                Maybe Text
forall a. Maybe a
Nothing
            | Bool
otherwise ->
                Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
role Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": no accepting control with both runs succeeded")

{- | One failing purpose's replay as a receipt carries it: the hash the node
reported, the traced hash of the same parameters once the replay applied
one, the reason it admitted or the cause it admits none — never both — and
the capture it was replayed from.
-}
data ReplayEvidence = ReplayEvidence
    { ReplayEvidence -> Text
replayDeployedHash :: Text
    , ReplayEvidence -> Maybe Text
replayTracedHash :: Maybe Text
    , ReplayEvidence -> Maybe Text
replayReason :: Maybe Text
    , ReplayEvidence -> Maybe Text
replayCause :: Maybe Text
    , ReplayEvidence -> Maybe Text
replayCaptureId :: Maybe Text
    }
    deriving stock (Int -> ReplayEvidence -> ShowS
[ReplayEvidence] -> ShowS
ReplayEvidence -> FilePath
(Int -> ReplayEvidence -> ShowS)
-> (ReplayEvidence -> FilePath)
-> ([ReplayEvidence] -> ShowS)
-> Show ReplayEvidence
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReplayEvidence -> ShowS
showsPrec :: Int -> ReplayEvidence -> ShowS
$cshow :: ReplayEvidence -> FilePath
show :: ReplayEvidence -> FilePath
$cshowList :: [ReplayEvidence] -> ShowS
showList :: [ReplayEvidence] -> ShowS
Show, ReplayEvidence -> ReplayEvidence -> Bool
(ReplayEvidence -> ReplayEvidence -> Bool)
-> (ReplayEvidence -> ReplayEvidence -> Bool) -> Eq ReplayEvidence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReplayEvidence -> ReplayEvidence -> Bool
== :: ReplayEvidence -> ReplayEvidence -> Bool
$c/= :: ReplayEvidence -> ReplayEvidence -> Bool
/= :: ReplayEvidence -> ReplayEvidence -> Bool
Eq)

instance ToJSON ReplayEvidence where
    toJSON :: ReplayEvidence -> Value
toJSON ReplayEvidence
e =
        [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
            (Key
"deployedHash" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ReplayEvidence -> Text
replayDeployedHash ReplayEvidence
e)
                Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [ Key
name Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
value
                  | (Key
name, Just Text
value) <-
                        [ (Key
"tracedHash", ReplayEvidence -> Maybe Text
replayTracedHash ReplayEvidence
e)
                        , (Key
"reason", ReplayEvidence -> Maybe Text
replayReason ReplayEvidence
e)
                        , (Key
"cause", ReplayEvidence -> Maybe Text
replayCause ReplayEvidence
e)
                        , (Key
"captureId", ReplayEvidence -> Maybe Text
replayCaptureId ReplayEvidence
e)
                        ]
                  ]

instance FromJSON ReplayEvidence where
    parseJSON :: Value -> Parser ReplayEvidence
parseJSON = FilePath
-> (Object -> Parser ReplayEvidence)
-> Value
-> Parser ReplayEvidence
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"ReplayEvidence" ((Object -> Parser ReplayEvidence)
 -> Value -> Parser ReplayEvidence)
-> (Object -> Parser ReplayEvidence)
-> Value
-> Parser ReplayEvidence
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> ReplayEvidence
ReplayEvidence
            (Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> ReplayEvidence)
-> Parser Text
-> Parser
     (Maybe Text
      -> Maybe Text -> Maybe Text -> Maybe Text -> ReplayEvidence)
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
"deployedHash"
            Parser
  (Maybe Text
   -> Maybe Text -> Maybe Text -> Maybe Text -> ReplayEvidence)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text -> Maybe Text -> Maybe Text -> ReplayEvidence)
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
"tracedHash"
            Parser (Maybe Text -> Maybe Text -> Maybe Text -> ReplayEvidence)
-> Parser (Maybe Text)
-> Parser (Maybe Text -> Maybe Text -> ReplayEvidence)
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
"reason"
            Parser (Maybe Text -> Maybe Text -> ReplayEvidence)
-> Parser (Maybe Text) -> Parser (Maybe Text -> ReplayEvidence)
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
"cause"
            Parser (Maybe Text -> ReplayEvidence)
-> Parser (Maybe Text) -> Parser ReplayEvidence
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
"captureId"

{- | A rejection's evidence, one entry per failing purpose the replay met; a
replay that ended before reaching any purpose gives each failing hash the
cause it ended with.
-}
rejectionEvidence
    :: Maybe Text
    -- ^ the capture's identity
    -> [Text]
    -- ^ the failing hashes the node reported
    -> [PurposeReplay]
    -> [ReplayClass]
    -- ^ what the replay established, in the index's order
    -> [ReplayEvidence]
rejectionEvidence :: Maybe Text
-> [Text] -> [PurposeReplay] -> [ReplayClass] -> [ReplayEvidence]
rejectionEvidence Maybe Text
captureId [Text]
failing [PurposeReplay]
purposes [ReplayClass]
classes = case [PurposeReplay]
purposes of
    [] ->
        [ Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> ReplayEvidence
ReplayEvidence Text
hash Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (UnobservedCause -> Text
causeName UnobservedCause
cause)) Maybe Text
captureId
        | Unobserved UnobservedCause
cause <- Int -> [ReplayClass] -> [ReplayClass]
forall a. Int -> [a] -> [a]
take Int
1 [ReplayClass]
classes
        , Text
hash <- [Text]
failing
        ]
    [PurposeReplay]
_ -> (PurposeReplay -> ReplayEvidence)
-> [PurposeReplay] -> [ReplayEvidence]
forall a b. (a -> b) -> [a] -> [b]
map PurposeReplay -> ReplayEvidence
evidence [PurposeReplay]
purposes
  where
    evidence :: PurposeReplay -> ReplayEvidence
evidence PurposeReplay
p = case PurposeReplay -> ReplayClass
prClass PurposeReplay
p of
        Admitted Text
reason ->
            Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> ReplayEvidence
ReplayEvidence
                (PurposeReplay -> Text
prDeployedHash PurposeReplay
p)
                (PurposeReplay -> Maybe Text
prTracedHash PurposeReplay
p)
                (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
reason)
                Maybe Text
forall a. Maybe a
Nothing
                Maybe Text
captureId
        Unobserved UnobservedCause
cause ->
            Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> ReplayEvidence
ReplayEvidence
                (PurposeReplay -> Text
prDeployedHash PurposeReplay
p)
                (PurposeReplay -> Maybe Text
prTracedHash PurposeReplay
p)
                Maybe Text
forall a. Maybe a
Nothing
                (Text -> Maybe Text
forall a. a -> Maybe a
Just (UnobservedCause -> Text
causeName UnobservedCause
cause))
                Maybe Text
captureId

{- | The traced build a receipt's replay reasons rely on: its source, compiler
and trace flags, and a digest of the untraced hashes it was held to.
-}
data ReplayCorrespondence = ReplayCorrespondence
    { ReplayCorrespondence -> Text
correspondenceSource :: Text
    , ReplayCorrespondence -> Text
correspondenceCompiler :: Text
    , ReplayCorrespondence -> Text
correspondenceFlags :: Text
    , ReplayCorrespondence -> Text
correspondenceDigest :: Text
    -- ^ SHA-256 over @title hash@ lines of the untraced hashes, in title order
    }
    deriving stock (Int -> ReplayCorrespondence -> ShowS
[ReplayCorrespondence] -> ShowS
ReplayCorrespondence -> FilePath
(Int -> ReplayCorrespondence -> ShowS)
-> (ReplayCorrespondence -> FilePath)
-> ([ReplayCorrespondence] -> ShowS)
-> Show ReplayCorrespondence
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReplayCorrespondence -> ShowS
showsPrec :: Int -> ReplayCorrespondence -> ShowS
$cshow :: ReplayCorrespondence -> FilePath
show :: ReplayCorrespondence -> FilePath
$cshowList :: [ReplayCorrespondence] -> ShowS
showList :: [ReplayCorrespondence] -> ShowS
Show, ReplayCorrespondence -> ReplayCorrespondence -> Bool
(ReplayCorrespondence -> ReplayCorrespondence -> Bool)
-> (ReplayCorrespondence -> ReplayCorrespondence -> Bool)
-> Eq ReplayCorrespondence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReplayCorrespondence -> ReplayCorrespondence -> Bool
== :: ReplayCorrespondence -> ReplayCorrespondence -> Bool
$c/= :: ReplayCorrespondence -> ReplayCorrespondence -> Bool
/= :: ReplayCorrespondence -> ReplayCorrespondence -> Bool
Eq)

instance ToJSON ReplayCorrespondence where
    toJSON :: ReplayCorrespondence -> Value
toJSON ReplayCorrespondence
c =
        [Pair] -> Value
object
            [ Key
"source" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ReplayCorrespondence -> Text
correspondenceSource ReplayCorrespondence
c
            , Key
"compiler" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ReplayCorrespondence -> Text
correspondenceCompiler ReplayCorrespondence
c
            , Key
"flags" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ReplayCorrespondence -> Text
correspondenceFlags ReplayCorrespondence
c
            , Key
"untracedHashesDigest" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ReplayCorrespondence -> Text
correspondenceDigest ReplayCorrespondence
c
            ]

instance FromJSON ReplayCorrespondence where
    parseJSON :: Value -> Parser ReplayCorrespondence
parseJSON = FilePath
-> (Object -> Parser ReplayCorrespondence)
-> Value
-> Parser ReplayCorrespondence
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"ReplayCorrespondence" ((Object -> Parser ReplayCorrespondence)
 -> Value -> Parser ReplayCorrespondence)
-> (Object -> Parser ReplayCorrespondence)
-> Value
-> Parser ReplayCorrespondence
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text -> Text -> Text -> Text -> ReplayCorrespondence
ReplayCorrespondence
            (Text -> Text -> Text -> Text -> ReplayCorrespondence)
-> Parser Text
-> Parser (Text -> Text -> Text -> ReplayCorrespondence)
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
"source"
            Parser (Text -> Text -> Text -> ReplayCorrespondence)
-> Parser Text -> Parser (Text -> Text -> ReplayCorrespondence)
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
"compiler"
            Parser (Text -> Text -> ReplayCorrespondence)
-> Parser Text -> Parser (Text -> ReplayCorrespondence)
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
"flags"
            Parser (Text -> ReplayCorrespondence)
-> Parser Text -> Parser ReplayCorrespondence
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
"untracedHashesDigest"

-- | The correspondence a traced build's provenance states.
correspondenceOf :: TracedProvenance -> ReplayCorrespondence
correspondenceOf :: TracedProvenance -> ReplayCorrespondence
correspondenceOf TracedProvenance
p =
    ReplayCorrespondence
        { correspondenceSource :: Text
correspondenceSource = TracedProvenance -> Text
tpSource TracedProvenance
p
        , correspondenceCompiler :: Text
correspondenceCompiler = TracedProvenance -> Text
tpCompiler TracedProvenance
p
        , correspondenceFlags :: Text
correspondenceFlags = TracedProvenance -> Text
tpFlags TracedProvenance
p
        , correspondenceDigest :: Text
correspondenceDigest =
            ByteString -> Text
sha256Hex
                ( Text -> ByteString
TE.encodeUtf8
                    ( [Text] -> Text
T.concat
                        [ Text
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
                        | (Text
title, Text
hash) <- Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (TracedProvenance -> Map Text Text
tpUntracedHashes TracedProvenance
p)
                        ]
                    )
                )
        }