{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}

{- | The ordinary CLI's story and the open-datum application's boundary,
judged from receipts.

Alice's story runs through the ordinary commands and is checked against
the receipts they print. Hand-built updates and an early release reach
the application's own script. An ordinary insert, update or terminate the
key's current entry rules out is refused at booking before signing,
naming the key and the client policy: a second insertion of a key that
is Active, an insertion of a key that is already Terminal, and an update
or a terminate of a key that is unknown or already Terminal.

And the registry refuses at its fold a booking the permissive builders
certify for a key it already holds: a second insertion of a key that is
Active, and an insertion of a key that is already Terminal. Neither can
take effect: the registry refuses to fold them because the key exists
(the model's @duplicate_refused_by_registry@ and
@resurrection_refused_by_registry@). Each refusal is paired with an
accepting control that differs only in the key: a key the registry has
never held, booked and folded the same way. Readbacks taken before and
after every refusal show that nothing moved.

Every result here is computed from receipts. A story is interpreted
twice: once against a node, where each action leaves one receipt, and
once over those receipts, where each check is recomputed. A missing,
misplaced or altered receipt changes the verdict; nothing is typed in.
-}
module Conformance.Cli.Controls
    ( -- * Actions
      Command (..)
    , applicationExecutable
    , registryExecutable
    , commandExecutable
    , commandPrefix
    , commandInvocation
    , provocationCommand
    , storyCommands
    , storyExecutables
    , introductionExecutablePhrase
    , registryPrefix
    , registryInvocation
    , commandName
    , Crafted (..)
    , craftedName
    , craftedPhrase
    , Target (..)
    , Requirement (..)
    , Indexer (..)
    , indexerName
    , IndexerRead (..)
    , Stated (..)
    , Account (..)
    , CliI (..)
    , Story

      -- * Statements
    , DuplicateRefused
    , ResurrectionRefused
    , duplicateRefused
    , resurrectionRefused
    , UpdateInversion
    , updateInversion
    , ClientPolicy
    , earlyRefusalPolicy
    , clientPolicyBindings
    , terminateBurnsActiveHolding
    , statementBindings
    , resolveStatement
    , obligationBindings
    , resolveObligation
    , cliSpecification

      -- * The stories
    , duplicateStory
    , resurrectionStory
    , earlyRefusalStory
    , lifecycleStory
    , boundaryStory
    , controlsStory
    , processStory
    , permanentStory
    , forbiddenInPermanent
    , actionsOf

      -- * Receipts
    , Receipt (..)
    , Observation (..)
    , Submission (..)
    , Resolved (..)
    , JournalSpan (..)
    , ProcessEvidence (..)
    , Provocation (..)
    , provocationName
    , emptyReceipt

      -- * Reading a node's rejection
    , rejectionEvidence
    , decodeIndexerRead
    , attribution

      -- * Verdicts and rendering, from receipts
    , ClauseStatus (..)
    , ClauseResult (..)
    , check
    , judge
    , held
    , outline
    , renderControls
    , validateControls
    ) where

import Conformance.Story.Binding
    ( Binding
    , BoundObligation (..)
    , mkBoundObligation
    )
import Conformance.Story.Specification
    ( Clause (..)
    , LeanCheck
    , Step (..)
    , Theorem
    , TheoremStory
    , action
    , bindCheck
    , bindTheorem
    , checkAction
    , clause
    , clauses
    , theorem
    , theoremBinding
    )
import Conformance.Story.Specification qualified as Specification
import Control.Monad (forM_, guard, unless, void, when)
import Control.Monad.Operational
    ( Program
    , ProgramViewT (Return, (:>>=))
    , view
    )
import Data.Aeson
    ( FromJSON (..)
    , ToJSON (..)
    , object
    , withObject
    , (.:)
    , (.:?)
    , (.=)
    )
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Bifunctor qualified as Bifunctor
import Data.ByteString.Lazy qualified as BL
import Data.Char (isDigit, isHexDigit, ord)
import Data.Either (fromRight, lefts, rights)
import Data.Int (Int64)
import Data.List (intercalate, isInfixOf, isPrefixOf, nub)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe)
import Data.Scientific qualified as Sci
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Vector qualified as V
import Data.Word (Word64)
import Language.Haskell.TH.Syntax (addDependentFile, lift, runIO)
import Text.Printf (printf)
import Text.Read (readMaybe)

import Conformance.Refusal
    ( RefusalMismatch (..)
    , matchRefusal
    , refusalScriptHashes
    )

-- ---------------------------------------------------------
-- Actions
-- ---------------------------------------------------------

{- | The ordinary commands, as a person runs them. An update names which
of the story's payloads it writes. A fold folds the registry's pending
request: the request names its key and edge, so the command takes no key,
payload, deposit or fold flag of its own.
-}
data Command = Create | Insert | Update Int | Terminate | Inspect | Fold
    deriving stock (Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
/= :: Command -> Command -> Bool
Eq, Int -> Command -> ShowS
[Command] -> ShowS
Command -> [Char]
(Int -> Command -> ShowS)
-> (Command -> [Char]) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Command -> ShowS
showsPrec :: Int -> Command -> ShowS
$cshow :: Command -> [Char]
show :: Command -> [Char]
$cshowList :: [Command] -> ShowS
showList :: [Command] -> ShowS
Show)

commandName :: Command -> String
commandName :: Command -> [Char]
commandName Command
c = case Command
c of
    Command
Create -> [Char]
"create"
    Command
Insert -> [Char]
"insert"
    Update Int
_ -> [Char]
"update"
    Command
Terminate -> [Char]
"terminate"
    Command
Inspect -> [Char]
"inspect"
    Command
Fold -> [Char]
"fold"

-- | The executable that runs the application's own verbs (#528).
applicationExecutable :: String
applicationExecutable :: [Char]
applicationExecutable = [Char]
"open-datum"

-- | The executable that keeps the registry's own verbs (#528).
registryExecutable :: String
registryExecutable :: [Char]
registryExecutable = [Char]
"singular registry"

{- | The executable that runs one ordinary command: the application's
verbs all run through `open-datum` (#528).
-}
commandExecutable :: Command -> String
commandExecutable :: Command -> [Char]
commandExecutable Command
_ = [Char]
applicationExecutable

{- | The executable and verb one ordinary command runs as, from the one
source the backend builds its arguments from and the rendering names.
-}
commandPrefix :: Command -> [String]
commandPrefix :: Command -> [[Char]]
commandPrefix Command
c = [Command -> [Char]
commandExecutable Command
c, Command -> [Char]
commandName Command
c]

-- | The same invocation as rendered in the description language.
commandInvocation :: Command -> String
commandInvocation :: Command -> [Char]
commandInvocation Command
c = Command -> [Char]
commandExecutable Command
c [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Command -> [Char]
commandName Command
c

-- | The executable and verb one registry command runs as.
registryPrefix :: String -> [String]
registryPrefix :: [Char] -> [[Char]]
registryPrefix [Char]
verb = [[Char]
"singular", [Char]
"registry", [Char]
verb]

-- | The same registry invocation as rendered.
registryInvocation :: String -> String
registryInvocation :: ShowS
registryInvocation [Char]
verb = [Char]
registryExecutable [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
verb

{- | A transaction built by hand against a key's live holding at the
application, and submitted without local evaluation so the node judges
it. Each shape but the first is one of the Aiken suite's refused updates,
or a release outside any fold.
-}
data Crafted
    = -- | The controller's update: same control, value and address
      HonestUpdate
    | -- | The same update, requiring another signer instead of the controller
      UpdateByStranger
    | -- | The continuation names another controller
      UpdateOtherController
    | -- | The continuation's protected deposit is changed
      UpdateDepositTampered
    | -- | The continuation, token and all, leaves for the controller's own address
      UpdateEscaped
    | -- | The continuation stays but the key's token leaves it
      UpdateTokenLeft
    | -- | The continuation holds one lovelace less than the protected deposit
      UpdateShortDeposit
    | -- | The continuation carries no datum
      UpdateWithoutDatum
    | -- | The continuation also carries an asset of another policy
      UpdateAddedAsset
    | -- | The holding is spent with @Release@ outside any fold
      EarlyWithdrawal
    | -- | An insertion booked with the controller's envelope, paid and signed by another wallet
      BookingByStranger
    | -- | An insertion booking whose request names another destination
      BookingOtherDestination
    | -- | An insertion booking whose request deposit is one lovelace short of the protected one
      BookingShortDeposit
    | -- | An insertion booking whose destination names no datum
      BookingNoDatum
    | -- | An insertion booking whose envelope names the state policy under another token name
      EnvelopeOtherStateName
    | -- | An insertion booking whose envelope names the token name under another policy
      EnvelopeOtherStatePolicy
    | -- | An insertion booking whose envelope names another registry's state asset
      EnvelopeOtherRegistry
    | -- | The controller's own booking of the key's termination
      TerminateBooking
    | -- | A termination booking by another wallet
      TerminateBookingByStranger
    | -- | A fold of another key's insertion that also spends the holding with @Release@
      ReleaseInOtherFold
    | -- | The controller's update, submitted without the application's script
      UpdateWithoutScript
    | -- | The terminating fold, folded by another wallet, paying the controller one lovelace short
      FoldPaysShort
    | -- | The same terminating fold, folded by another wallet, paying the controller in full
      FoldPaysInFull
    | -- | One fold of two terminations for one controller, paying it one lovelace short of the sum
      FoldTwoReleasesShort
    | -- | The same fold, paying it one released deposit where the sum of two is owed
      FoldTwoReleasesOneFloor
    | -- | The same fold, paying it the sum in full
      FoldTwoReleasesInFull
    | -- | One fold of an insertion and a termination for one controller, paying it one lovelace short
      FoldMixedShort
    | -- | The same fold, paying it in full
      FoldMixedInFull
    deriving stock (Crafted -> Crafted -> Bool
(Crafted -> Crafted -> Bool)
-> (Crafted -> Crafted -> Bool) -> Eq Crafted
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Crafted -> Crafted -> Bool
== :: Crafted -> Crafted -> Bool
$c/= :: Crafted -> Crafted -> Bool
/= :: Crafted -> Crafted -> Bool
Eq, Int -> Crafted -> ShowS
[Crafted] -> ShowS
Crafted -> [Char]
(Int -> Crafted -> ShowS)
-> (Crafted -> [Char]) -> ([Crafted] -> ShowS) -> Show Crafted
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Crafted -> ShowS
showsPrec :: Int -> Crafted -> ShowS
$cshow :: Crafted -> [Char]
show :: Crafted -> [Char]
$cshowList :: [Crafted] -> ShowS
showList :: [Crafted] -> ShowS
Show, Int -> Crafted
Crafted -> Int
Crafted -> [Crafted]
Crafted -> Crafted
Crafted -> Crafted -> [Crafted]
Crafted -> Crafted -> Crafted -> [Crafted]
(Crafted -> Crafted)
-> (Crafted -> Crafted)
-> (Int -> Crafted)
-> (Crafted -> Int)
-> (Crafted -> [Crafted])
-> (Crafted -> Crafted -> [Crafted])
-> (Crafted -> Crafted -> [Crafted])
-> (Crafted -> Crafted -> Crafted -> [Crafted])
-> Enum Crafted
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 :: Crafted -> Crafted
succ :: Crafted -> Crafted
$cpred :: Crafted -> Crafted
pred :: Crafted -> Crafted
$ctoEnum :: Int -> Crafted
toEnum :: Int -> Crafted
$cfromEnum :: Crafted -> Int
fromEnum :: Crafted -> Int
$cenumFrom :: Crafted -> [Crafted]
enumFrom :: Crafted -> [Crafted]
$cenumFromThen :: Crafted -> Crafted -> [Crafted]
enumFromThen :: Crafted -> Crafted -> [Crafted]
$cenumFromTo :: Crafted -> Crafted -> [Crafted]
enumFromTo :: Crafted -> Crafted -> [Crafted]
$cenumFromThenTo :: Crafted -> Crafted -> Crafted -> [Crafted]
enumFromThenTo :: Crafted -> Crafted -> Crafted -> [Crafted]
Enum, Crafted
Crafted -> Crafted -> Bounded Crafted
forall a. a -> a -> Bounded a
$cminBound :: Crafted
minBound :: Crafted
$cmaxBound :: Crafted
maxBound :: Crafted
Bounded)

craftedName :: Crafted -> String
craftedName :: Crafted -> [Char]
craftedName Crafted
c = case Crafted
c of
    Crafted
HonestUpdate -> [Char]
"update"
    Crafted
UpdateByStranger -> [Char]
"update-by-stranger"
    Crafted
UpdateOtherController -> [Char]
"update-other-controller"
    Crafted
UpdateDepositTampered -> [Char]
"update-deposit-tampered"
    Crafted
UpdateEscaped -> [Char]
"update-escaped"
    Crafted
UpdateTokenLeft -> [Char]
"update-token-left"
    Crafted
UpdateShortDeposit -> [Char]
"update-short-deposit"
    Crafted
UpdateWithoutDatum -> [Char]
"update-without-datum"
    Crafted
UpdateAddedAsset -> [Char]
"update-added-asset"
    Crafted
EarlyWithdrawal -> [Char]
"early-withdrawal"
    Crafted
BookingByStranger -> [Char]
"booking-by-stranger"
    Crafted
BookingOtherDestination -> [Char]
"booking-other-destination"
    Crafted
BookingShortDeposit -> [Char]
"booking-short-deposit"
    Crafted
BookingNoDatum -> [Char]
"booking-no-datum"
    Crafted
EnvelopeOtherStateName -> [Char]
"envelope-other-state-name"
    Crafted
EnvelopeOtherStatePolicy -> [Char]
"envelope-other-state-policy"
    Crafted
EnvelopeOtherRegistry -> [Char]
"envelope-other-registry"
    Crafted
TerminateBooking -> [Char]
"terminate-booking"
    Crafted
TerminateBookingByStranger -> [Char]
"terminate-booking-by-stranger"
    Crafted
ReleaseInOtherFold -> [Char]
"release-in-other-fold"
    Crafted
UpdateWithoutScript -> [Char]
"update-without-script"
    Crafted
FoldPaysShort -> [Char]
"fold-pays-short"
    Crafted
FoldPaysInFull -> [Char]
"fold-pays-in-full"
    Crafted
FoldTwoReleasesShort -> [Char]
"fold-two-releases-short"
    Crafted
FoldTwoReleasesOneFloor -> [Char]
"fold-two-releases-one-floor"
    Crafted
FoldTwoReleasesInFull -> [Char]
"fold-two-releases-in-full"
    Crafted
FoldMixedShort -> [Char]
"fold-mixed-short"
    Crafted
FoldMixedInFull -> [Char]
"fold-mixed-in-full"

{- | An ordinary command run under a condition of its process, not of the
ledger: another process, a changed or missing file, an absent node, or a
kill. What the command does then is the client's obligation under the
CLI's own specification; no model statement covers it.
-}
data Provocation
    = -- | @insert@, while another process holds the registry's lock
      WhileLocked
    | -- | @inspect@, with the public history it needs withheld
      WithoutHistory
    | -- | @inspect@, against a node socket that does not exist
      WithoutNode
    | -- | @terminate@, killed once the node accepted its fold
      TerminateKilled
    | -- | @update@ of another key, once the @terminate@ was killed
      UpdateAfterKill
    | -- | @create@ on a new registry, killed once the node accepted its boot
      CreateKilled
    | -- | @create@ again, on that interrupted registry
      CreateAgain
    | {- | @create@ from the same wallet on the same seed twice; the second is
      held before the registry's lock while the first @create@ completes,
      and is refused because the registry exists
      -}
      LateCreate
    | -- | @create@, from a wallet that cannot fund every publication
      UnderfundedCreate
    | {- | @update@, held once the node accepted it while the node is stopped,
      then released; the last action of a story, since the node is gone
      -}
      NodeLost
    deriving stock (Provocation -> Provocation -> Bool
(Provocation -> Provocation -> Bool)
-> (Provocation -> Provocation -> Bool) -> Eq Provocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Provocation -> Provocation -> Bool
== :: Provocation -> Provocation -> Bool
$c/= :: Provocation -> Provocation -> Bool
/= :: Provocation -> Provocation -> Bool
Eq, Int -> Provocation -> ShowS
[Provocation] -> ShowS
Provocation -> [Char]
(Int -> Provocation -> ShowS)
-> (Provocation -> [Char])
-> ([Provocation] -> ShowS)
-> Show Provocation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Provocation -> ShowS
showsPrec :: Int -> Provocation -> ShowS
$cshow :: Provocation -> [Char]
show :: Provocation -> [Char]
$cshowList :: [Provocation] -> ShowS
showList :: [Provocation] -> ShowS
Show, Int -> Provocation
Provocation -> Int
Provocation -> [Provocation]
Provocation -> Provocation
Provocation -> Provocation -> [Provocation]
Provocation -> Provocation -> Provocation -> [Provocation]
(Provocation -> Provocation)
-> (Provocation -> Provocation)
-> (Int -> Provocation)
-> (Provocation -> Int)
-> (Provocation -> [Provocation])
-> (Provocation -> Provocation -> [Provocation])
-> (Provocation -> Provocation -> [Provocation])
-> (Provocation -> Provocation -> Provocation -> [Provocation])
-> Enum Provocation
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 :: Provocation -> Provocation
succ :: Provocation -> Provocation
$cpred :: Provocation -> Provocation
pred :: Provocation -> Provocation
$ctoEnum :: Int -> Provocation
toEnum :: Int -> Provocation
$cfromEnum :: Provocation -> Int
fromEnum :: Provocation -> Int
$cenumFrom :: Provocation -> [Provocation]
enumFrom :: Provocation -> [Provocation]
$cenumFromThen :: Provocation -> Provocation -> [Provocation]
enumFromThen :: Provocation -> Provocation -> [Provocation]
$cenumFromTo :: Provocation -> Provocation -> [Provocation]
enumFromTo :: Provocation -> Provocation -> [Provocation]
$cenumFromThenTo :: Provocation -> Provocation -> Provocation -> [Provocation]
enumFromThenTo :: Provocation -> Provocation -> Provocation -> [Provocation]
Enum, Provocation
Provocation -> Provocation -> Bounded Provocation
forall a. a -> a -> Bounded a
$cminBound :: Provocation
minBound :: Provocation
$cmaxBound :: Provocation
maxBound :: Provocation
Bounded)

provocationName :: Provocation -> String
provocationName :: Provocation -> [Char]
provocationName Provocation
p = case Provocation
p of
    Provocation
WhileLocked -> [Char]
"insert-while-locked"
    Provocation
WithoutHistory -> [Char]
"inspect-without-history"
    Provocation
WithoutNode -> [Char]
"inspect-without-node"
    Provocation
TerminateKilled -> [Char]
"terminate-killed"
    Provocation
UpdateAfterKill -> [Char]
"update-after-kill"
    Provocation
CreateKilled -> [Char]
"create-killed"
    Provocation
CreateAgain -> [Char]
"create-again"
    Provocation
LateCreate -> [Char]
"create-late"
    Provocation
UnderfundedCreate -> [Char]
"create-underfunded"
    Provocation
NodeLost -> [Char]
"update-node-lost"

-- | The ordinary command a provocation runs, from the same command its phrase names (#528).
provocationCommand :: Provocation -> Command
provocationCommand :: Provocation -> Command
provocationCommand Provocation
p = case Provocation
p of
    Provocation
WhileLocked -> Command
Insert
    Provocation
WithoutHistory -> Command
Inspect
    Provocation
WithoutNode -> Command
Inspect
    Provocation
TerminateKilled -> Command
Terminate
    Provocation
UpdateAfterKill -> Int -> Command
Update Int
0
    Provocation
CreateKilled -> Command
Create
    Provocation
CreateAgain -> Command
Create
    Provocation
LateCreate -> Command
Create
    Provocation
UnderfundedCreate -> Command
Create
    Provocation
NodeLost -> Int -> Command
Update Int
0

-- | A provoked command, in the description language, naming the same command it runs.
provocationPhrase :: Provocation -> String
provocationPhrase :: Provocation -> [Char]
provocationPhrase Provocation
p =
    let inv :: [Char]
inv = Command -> [Char]
commandInvocation (Provocation -> Command
provocationCommand Provocation
p)
    in  case Provocation
p of
            Provocation
WhileLocked ->
                [Char]
"Run `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` while another process holds the registry's lock"
            Provocation
WithoutHistory -> [Char]
"Run `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` with the public history it needs withheld"
            Provocation
WithoutNode -> [Char]
"Run `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` against a node socket that does not exist"
            Provocation
TerminateKilled -> [Char]
"Run `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` and kill it once the node accepted its fold"
            Provocation
UpdateAfterKill ->
                [Char]
"Run `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` of another key once that terminate was killed"
            Provocation
CreateKilled ->
                [Char]
"Run `"
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` on a new registry and kill it once the node accepted its boot"
            Provocation
CreateAgain -> [Char]
"Run `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` again on that registry"
            Provocation
LateCreate ->
                [Char]
"Run `"
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` twice from the same wallet on the same seed, the second held before the registry's lock while the first create completes, and refused because the registry exists"
            Provocation
UnderfundedCreate ->
                [Char]
"Run `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` from a wallet that cannot fund every publication"
            Provocation
NodeLost ->
                [Char]
"Run `"
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
inv
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`, hold it once the node accepted it, stop the node, then release it"

-- | A registry the story works in: its own directory and its own boot.
newtype Target = Target String
    deriving stock (Target -> Target -> Bool
(Target -> Target -> Bool)
-> (Target -> Target -> Bool) -> Eq Target
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Target -> Target -> Bool
== :: Target -> Target -> Bool
$c/= :: Target -> Target -> Bool
/= :: Target -> Target -> Bool
Eq, Int -> Target -> ShowS
[Target] -> ShowS
Target -> [Char]
(Int -> Target -> ShowS)
-> (Target -> [Char]) -> ([Target] -> ShowS) -> Show Target
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Target -> ShowS
showsPrec :: Int -> Target -> ShowS
$cshow :: Target -> [Char]
show :: Target -> [Char]
$cshowList :: [Target] -> ShowS
showList :: [Target] -> ShowS
Show)

-- | What a check requires of the receipts it is given.
data Requirement
    = -- | One command receipt whose outcome is @success@
      CommandSucceeded
    | -- | One booking or fold the node accepted and the chain confirmed
      Accepted
    | {- | One fold submitted without local evaluation, which the node
      refused, naming the registry's own state validator as the script that
      failed
      -}
      RefusedByState
    | {- | Two readbacks, before and after, that agree on the registry's
      root, the key's holding, the pending requests and the wallet
      -}
      Unchanged
    | {- | A command receipt whose outcome is @partial@ and which names its
      pending request, and a readback after it that finds that request
      pending
      -}
      PartialPending
    | {- | An ordinary command refused at booking before signing, with a
      readback of its key: the command's outcome is @client-refusal@,
      its reason names the key and the client-policy refusal for the
      leaf the readback authenticates, it names no pending request and
      submitted nothing, and the registry's journal did not move
      -}
      BookingRefused
    | {- | One hand-built transaction submitted without local evaluation,
      which the node refused, naming the applied open-datum script as the
      script that failed
      -}
      RefusedByApplication
    | {- | Two readbacks that agree on the registry's root, the key's holding
      and the wallet
      -}
      HoldingUnchanged
    | {- | The create and insert receipts: the inserted envelope names the
      created registry's state asset and active policy
      -}
      SameRegistry
    | {- | The insert and inspect receipts: the key reads Active, its one
      holding is the output the insert delivered, carrying the inserted
      envelope inline and at least its protected deposit
      -}
      Delivered
    | {- | Inspect, update, inspect: the root does not move, the holding is
      the update's output, the payload is the update's and the control and
      deposit are unchanged
      -}
      PayloadReplaced
    | {- | Inspect, terminate, inspect: the key reads Terminal with no
      holding, and the terminate released the protected deposit it held
      -}
      Released
    | -- | One readback the node answered
      Observed
    | {- | Two readbacks that agree on the registry's root, its pending
      requests and the wallet
      -}
      RegistryUnchanged
    | {- | Command receipts that all succeeded, in one registry: the premise
      a telling builds on
      -}
      Established
    | {- | Command receipts that all succeeded, then a fresh reading of the
      exact key: an @ that authenticated it Active against the
      chain's root, or a readback whose public replay agrees with that root
      -}
      ReachedActive
    | -- | The same, reading the key Terminal
      ReachedTerminal
    | {- | One hand-built transaction the node rejected before any script ran,
      although its rejection names the applied open-datum script: the
      control that such a rejection is not counted as the script's refusal
      -}
      RejectedBeforeScripts
    | {- | A provoked command refused before submitting: its outcome is the
      class its condition names, and the registry's journal did not move
      -}
      RefusedBeforeSubmitting
    | {- | The create receipt of a wallet that cannot fund every
      publication: refused before anything was submitted, with the
      publication funding named, its directory untouched and its seed
      still unspent
      -}
      CreateUnderfunded
    | {- | An inspect by the registry's own actor and one by a second actor
      starting from an empty directory with only the state token: both
      succeeded and read the same registry
      -}
      TokenOnlyReading
    | {- | A booking, an ordinary token-only fold of that booking and an
      inspect after it: the booking was accepted, the fold succeeded on
      the booking's own request, and the key reads Active under the
      fold's envelope and root
      -}
      FoldConsumed
    | {- | A provoked @inspect@: its outcome is the class its condition
      names, and it printed no leaf
      -}
      NoLeafPrinted
    | {- | A killed command: the journal's last line when it stopped is the
      node's acceptance of the step it was killed at, and that submission's
      body was kept
      -}
      StoppedAfterAcceptance
    | {- | The killed @terminate@ and the @update@ after it: either the
      update succeeded, having replayed the killed fold at its chain root and
      observed it, or it was refused before submitting anything, naming the
      killed fold and its case
      -}
      ReconciledOrRefused
    | {- | The killed @terminate@, the @update@ after it and a later
      @inspect@ of its key: the key reads Terminal, and the killed fold was
      replayed at the chain root, never resubmitted and observed exactly once across
      the update's and the inspect's receipts
      -}
      ResolvedFromChain
    | {- | The killed @create@ and a later @inspect@ of its registry: the
      inspect reads the incomplete create's identity from its journal,
      observed the killed boot from the chain and printed no leaf
      -}
      IncompleteCreateRead
    | {- | The late @create@: refused because the registry exists, the first
      registry's saved files unchanged, and the late wallet's seed unspent
      -}
      LateCreateRefused
    | {- | The @update@ that lost its node: it ended within its confirmation
      bound, partial or timed out, naming the transaction it submitted, which
      the journal keeps unresolved
      -}
      BoundedAfterNodeLoss
    | {- | The retraction of a pending request: the insertion's receipt names
      it, the readbacks before and after agree that exactly that request
      left, the retained body spends exactly that request, the registry's
      root did not move, and the wallet gained the bond it released less the
      fee the retraction paid
      -}
      Reclaimed
    | {- | A node-judged transaction of a take on an existing registry: the
      operator set an explicit collateral allowance, and the body states a
      total collateral within it and a return of the rest of its funding
      output
      -}
      ExposureBounded
    | {- | The fresh inspect of an Active key and one public indexer's read
      of that key's token: the indexer found exactly one output holding
      exactly one of the token, under the policy and asset name the inspect
      names, and its output reference, datum bytes, datum hash and chain
      position are the node's, within the lag
      -}
      IndexerAgrees
    deriving stock (Requirement -> Requirement -> Bool
(Requirement -> Requirement -> Bool)
-> (Requirement -> Requirement -> Bool) -> Eq Requirement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Requirement -> Requirement -> Bool
== :: Requirement -> Requirement -> Bool
$c/= :: Requirement -> Requirement -> Bool
/= :: Requirement -> Requirement -> Bool
Eq, Int -> Requirement -> ShowS
[Requirement] -> ShowS
Requirement -> [Char]
(Int -> Requirement -> ShowS)
-> (Requirement -> [Char])
-> ([Requirement] -> ShowS)
-> Show Requirement
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Requirement -> ShowS
showsPrec :: Int -> Requirement -> ShowS
$cshow :: Requirement -> [Char]
show :: Requirement -> [Char]
$cshowList :: [Requirement] -> ShowS
showList :: [Requirement] -> ShowS
Show, Int -> Requirement
Requirement -> Int
Requirement -> [Requirement]
Requirement -> Requirement
Requirement -> Requirement -> [Requirement]
Requirement -> Requirement -> Requirement -> [Requirement]
(Requirement -> Requirement)
-> (Requirement -> Requirement)
-> (Int -> Requirement)
-> (Requirement -> Int)
-> (Requirement -> [Requirement])
-> (Requirement -> Requirement -> [Requirement])
-> (Requirement -> Requirement -> [Requirement])
-> (Requirement -> Requirement -> Requirement -> [Requirement])
-> Enum Requirement
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 :: Requirement -> Requirement
succ :: Requirement -> Requirement
$cpred :: Requirement -> Requirement
pred :: Requirement -> Requirement
$ctoEnum :: Int -> Requirement
toEnum :: Int -> Requirement
$cfromEnum :: Requirement -> Int
fromEnum :: Requirement -> Int
$cenumFrom :: Requirement -> [Requirement]
enumFrom :: Requirement -> [Requirement]
$cenumFromThen :: Requirement -> Requirement -> [Requirement]
enumFromThen :: Requirement -> Requirement -> [Requirement]
$cenumFromTo :: Requirement -> Requirement -> [Requirement]
enumFromTo :: Requirement -> Requirement -> [Requirement]
$cenumFromThenTo :: Requirement -> Requirement -> Requirement -> [Requirement]
enumFromThenTo :: Requirement -> Requirement -> Requirement -> [Requirement]
Enum, Requirement
Requirement -> Requirement -> Bounded Requirement
forall a. a -> a -> Bounded a
$cminBound :: Requirement
minBound :: Requirement
$cmaxBound :: Requirement
maxBound :: Requirement
Bounded)

{- | One step of the story. Every action but 'Require' leaves exactly one
receipt; 'Require' is computed from receipts and leaves none.
-}
data CliI res where
    -- | Run one ordinary command against a registry, for a key
    Run :: Command -> Target -> String -> CliI Receipt
    {- | Run one ordinary command from this actor's directory against the
    registry another target created, naming it only by its state token:
    the actor's directory starts empty and receives the token, nothing
    else of the registry
    -}
    RunByToken :: Target -> Target -> Command -> String -> CliI Receipt
    {- | Book an insertion of the key through the application, as the
    ordinary insert does, and stop before its fold
    -}
    Book :: Target -> String -> CliI Receipt
    {- | Fold that booking, submitted without evaluating its scripts
    locally, so the node judges it
    -}
    FoldUnevaluated :: Target -> String -> CliI Receipt
    {- | Read the registry's root, the key's holding, the pending requests
    and the wallet back from the node
    -}
    Observe :: Target -> String -> CliI Receipt
    -- | Submit a hand-built transaction against the key's live holding
    Craft :: Crafted -> Target -> String -> CliI Receipt
    -- | Run an ordinary command under a condition of its process
    Provoke :: Provocation -> Target -> String -> CliI Receipt
    {- | Retract the request a refused insertion left pending, as its owner, in
    the request's own retract window, and read the registry back: the bond
    returns, the fee is paid. It carries the command receipt that names the
    request and the readback that saw it pending: the request is that one, in
    the state that readback saw, or nothing is retracted
    -}
    Reclaim :: Target -> String -> Receipt -> Receipt -> CliI Receipt
    {- | Ask one public indexer, read-only, for the Active key's token, from
    the policy and asset name the fresh inspect names, and compare what it
    finds with that inspect. It writes nothing; an indexer that is missing,
    unreachable, stale or in disagreement ends the take before its next
    write
    -}
    ReadIndexer :: Indexer -> Target -> String -> Receipt -> CliI Receipt
    Require :: Requirement -> [Receipt] -> CliI ()
    {- | The enclosing clause's promise is retired, for this reason. The clause
    keeps its words as history and is judged retired, never from a receipt;
    it leaves no receipt
    -}
    Retire :: String -> CliI ()

type Story = Specification.Story CliI

-- ---------------------------------------------------------
-- Statements
-- ---------------------------------------------------------

-- | @OpenDatumApplication.Statements.duplicate_refused_by_registry@
data DuplicateRefused

-- | @OpenDatumApplication.Statements.resurrection_refused_by_registry@
data ResurrectionRefused

{- | The application model revision the statements are read at: the one
commit in @model-revision@, read when this module compiles. The release
archive states the same file as @MODEL-REVISION@.
-}
modelRevision :: String
modelRevision :: [Char]
modelRevision =
    $( do
        let path = "model-revision"
        addDependentFile path
        revision <- runIO (readFile path)
        case lines revision of
            [commit]
                | length commit == 40 && all isHexDigit commit -> lift commit
            _ -> fail ("model-revision is not one commit: " <> show revision)
     )

duplicateRefused :: Theorem DuplicateRefused
duplicateRefused :: Theorem DuplicateRefused
duplicateRefused =
    BoundObligation -> Theorem DuplicateRefused
forall {k} (thm :: k). BoundObligation -> Theorem thm
bindTheorem (BoundObligation -> Theorem DuplicateRefused)
-> BoundObligation -> Theorem DuplicateRefused
forall a b. (a -> b) -> a -> b
$
        [Char] -> [Char] -> [Char] -> BoundObligation
mkBoundObligation
            [Char]
"OpenDatumApplication.Statements.duplicate_refused_by_registry"
            [Char]
"25ebf9423d2ed30a61be2f77698905a885312aedd0a65f1078760c0508fe599e"
            [Char]
modelRevision

resurrectionRefused :: Theorem ResurrectionRefused
resurrectionRefused :: Theorem ResurrectionRefused
resurrectionRefused =
    BoundObligation -> Theorem ResurrectionRefused
forall {k} (thm :: k). BoundObligation -> Theorem thm
bindTheorem (BoundObligation -> Theorem ResurrectionRefused)
-> BoundObligation -> Theorem ResurrectionRefused
forall a b. (a -> b) -> a -> b
$
        [Char] -> [Char] -> [Char] -> BoundObligation
mkBoundObligation
            [Char]
"OpenDatumApplication.Statements.resurrection_refused_by_registry"
            [Char]
"2a84afdffe5b91cfd8f0fe9da7980093e77b75107fdbec76f28ba0d2e5bc6184"
            [Char]
modelRevision

-- | Statement markers for the lifecycle and the application's boundary.
data InsertionHoldingInline

data UpdateKeepsRegistry

data UpdatePayloadFree

data ReleaseBurnsAtomically

data UpdateRequiresController

data UpdatePreservesCustody

data OnlyFoldReleases

bound :: String -> String -> Theorem thm
bound :: forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound [Char]
name [Char]
digest =
    BoundObligation -> Theorem thm
forall {k} (thm :: k). BoundObligation -> Theorem thm
bindTheorem
        ( [Char] -> [Char] -> [Char] -> BoundObligation
mkBoundObligation
            ([Char]
"OpenDatumApplication.Statements." [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
name)
            [Char]
digest
            [Char]
modelRevision
        )

insertionHoldingInline :: Theorem InsertionHoldingInline
insertionHoldingInline :: Theorem InsertionHoldingInline
insertionHoldingInline =
    [Char] -> [Char] -> Theorem InsertionHoldingInline
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"insertion_holding_inline"
        [Char]
"844d0d9bdbc5bae7875fcd07950bd37919dac92e588a40da79368cbd3b776a18"

updateKeepsRegistry :: Theorem UpdateKeepsRegistry
updateKeepsRegistry :: Theorem UpdateKeepsRegistry
updateKeepsRegistry =
    [Char] -> [Char] -> Theorem UpdateKeepsRegistry
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"update_keeps_registry"
        [Char]
"1d0bd504d8cbe90ccfcdc7c2a32096a4e370c8652a72d485b01715d5963a3e12"

updatePayloadFree :: Theorem UpdatePayloadFree
updatePayloadFree :: Theorem UpdatePayloadFree
updatePayloadFree =
    [Char] -> [Char] -> Theorem UpdatePayloadFree
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"update_payload_free"
        [Char]
"6577b1757d0291d77a26826fca516543cddbda7276cd515263e81e95ee32886e"

releaseBurnsAtomically :: Theorem ReleaseBurnsAtomically
releaseBurnsAtomically :: Theorem ReleaseBurnsAtomically
releaseBurnsAtomically =
    [Char] -> [Char] -> Theorem ReleaseBurnsAtomically
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"release_burns_atomically"
        [Char]
"7e963ef2c919db15cc34ed9965b55d21d030f6de4b524690720126e4aacdf737"

updateRequiresController :: Theorem UpdateRequiresController
updateRequiresController :: Theorem UpdateRequiresController
updateRequiresController =
    [Char] -> [Char] -> Theorem UpdateRequiresController
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"update_requires_controller"
        [Char]
"bdc250edc8194c67ddb79deb53307780d2ce6e9b865edc11fceceba564b912f7"

updatePreservesCustody :: Theorem UpdatePreservesCustody
updatePreservesCustody :: Theorem UpdatePreservesCustody
updatePreservesCustody =
    [Char] -> [Char] -> Theorem UpdatePreservesCustody
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"update_preserves_custody"
        [Char]
"56a7b787884ab930d2ccb9524d13fb31a391f5c08aab2ac727080d39c4d498cc"

onlyFoldReleases :: Theorem OnlyFoldReleases
onlyFoldReleases :: Theorem OnlyFoldReleases
onlyFoldReleases =
    [Char] -> [Char] -> Theorem OnlyFoldReleases
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"only_fold_releases"
        [Char]
"aefd57a28089717e856d92cc5ae3c03404e5d47420827f0659798909c080f84d"

-- | Statement markers for bookings and the terminating fold's settlement.
data BookInsertInversion

data InsertionRequiresRegistryIdentity

data BookTerminateInversion

data FoldInversion

data FoldSettlesAdditively

bookInsertInversion :: Theorem BookInsertInversion
bookInsertInversion :: Theorem BookInsertInversion
bookInsertInversion =
    [Char] -> [Char] -> Theorem BookInsertInversion
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"bookInsert_inversion"
        [Char]
"52ba3e1fa9dfe4b2fb19471ab5cac3e1ef6e4aa86b928f9b7aa6aec7399f1140"

insertionRequiresRegistryIdentity
    :: Theorem InsertionRequiresRegistryIdentity
insertionRequiresRegistryIdentity :: Theorem InsertionRequiresRegistryIdentity
insertionRequiresRegistryIdentity =
    [Char] -> [Char] -> Theorem InsertionRequiresRegistryIdentity
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"insertion_requires_registry_identity"
        [Char]
"73e322298b13ab5d17501865501f684e183c71c486d60c882ff61f68a76a46df"

bookTerminateInversion :: Theorem BookTerminateInversion
bookTerminateInversion :: Theorem BookTerminateInversion
bookTerminateInversion =
    [Char] -> [Char] -> Theorem BookTerminateInversion
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"bookTerminate_inversion"
        [Char]
"a7d7faecdfd89fd337d2219ab5d9a705e287bcce155b2182e51fa4612c6d196c"

foldInversion :: Theorem FoldInversion
foldInversion :: Theorem FoldInversion
foldInversion =
    [Char] -> [Char] -> Theorem FoldInversion
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"fold_inversion"
        [Char]
"e07a28190a45fdc990042b2f83625ae32b448119a91c2c758a34623dfd7df919"

foldSettlesAdditively :: Theorem FoldSettlesAdditively
foldSettlesAdditively :: Theorem FoldSettlesAdditively
foldSettlesAdditively =
    [Char] -> [Char] -> Theorem FoldSettlesAdditively
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"fold_settles_additively"
        [Char]
"0038394b2e4e770589310e9c7461adb80a5c9a8d90e3a83456e2cfa36ae2ba0d"

-- | Statement markers for the early booking refusals.
data UpdateInversion

updateInversion :: Theorem UpdateInversion
updateInversion :: Theorem UpdateInversion
updateInversion =
    [Char] -> [Char] -> Theorem UpdateInversion
forall {k} (thm :: k). [Char] -> [Char] -> Theorem thm
bound
        [Char]
"update_inversion"
        [Char]
"e8702fb6ae5e5dfe4de4ba3f7e5a5f06e63231bd0b6273def555ed79d29adc89"

{- | The client's own booking policy: an update the key's current entry
rules out is refused before anything is signed, naming the key and the
client policy. It claims no Lean theorem and no row of the CLI's
specification (issue #486: kept labelled as client policy unless the
model is amended); only the accepted payload update below is told under
`update_inversion`, which states exactly that accepted step.
-}
data ClientPolicy

earlyRefusalPolicy :: Theorem ClientPolicy
earlyRefusalPolicy :: Theorem ClientPolicy
earlyRefusalPolicy =
    BoundObligation -> Theorem ClientPolicy
forall {k} (thm :: k). BoundObligation -> Theorem thm
bindTheorem
        ( [Char] -> [Char] -> [Char] -> BoundObligation
mkBoundObligation
            [Char]
"client-policy-booking-refused"
            [Char]
"no-theorem-claimed"
            [Char]
"client-policy"
        )

-- | The client-policy tellings the controls bind, claiming no theorem.
clientPolicyBindings :: [Binding]
clientPolicyBindings :: [BoundObligation]
clientPolicyBindings = [Theorem ClientPolicy -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ClientPolicy
earlyRefusalPolicy]

-- | Every statement the stories bind.
statementBindings :: [Binding]
statementBindings :: [BoundObligation]
statementBindings =
    [ Theorem DuplicateRefused -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem DuplicateRefused
duplicateRefused
    , Theorem ResurrectionRefused -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ResurrectionRefused
resurrectionRefused
    , Theorem InsertionHoldingInline -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem InsertionHoldingInline
insertionHoldingInline
    , Theorem UpdateKeepsRegistry -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem UpdateKeepsRegistry
updateKeepsRegistry
    , Theorem UpdatePayloadFree -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem UpdatePayloadFree
updatePayloadFree
    , Theorem ReleaseBurnsAtomically -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ReleaseBurnsAtomically
releaseBurnsAtomically
    , Theorem UpdateRequiresController -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem UpdateRequiresController
updateRequiresController
    , Theorem UpdatePreservesCustody -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem UpdatePreservesCustody
updatePreservesCustody
    , Theorem OnlyFoldReleases -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem OnlyFoldReleases
onlyFoldReleases
    , Theorem BookInsertInversion -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem BookInsertInversion
bookInsertInversion
    , Theorem InsertionRequiresRegistryIdentity -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem InsertionRequiresRegistryIdentity
insertionRequiresRegistryIdentity
    , Theorem BookTerminateInversion -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem BookTerminateInversion
bookTerminateInversion
    , Theorem FoldSettlesAdditively -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem FoldSettlesAdditively
foldSettlesAdditively
    , Theorem FoldInversion -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem FoldInversion
foldInversion
    , Theorem UpdateInversion -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem UpdateInversion
updateInversion
    ]

{- | A client obligation: a row of the CLI's own specification. It is not a
model statement; what it covers is the command's behaviour under
conditions of its process, which no Lean statement describes.
-}
data ClientObligation

-- | The specification whose rows the client obligations are.
cliSpecification :: String
cliSpecification :: [Char]
cliSpecification = [Char]
"specs/299-singular-cli/spec.md"

-- | A row, bound by its identifier and the SHA-256 of its exact line.
obligationRow :: String -> String -> Theorem ClientObligation
obligationRow :: [Char] -> [Char] -> Theorem ClientObligation
obligationRow [Char]
name [Char]
digest =
    BoundObligation -> Theorem ClientObligation
forall {k} (thm :: k). BoundObligation -> Theorem thm
bindTheorem ([Char] -> [Char] -> [Char] -> BoundObligation
mkBoundObligation [Char]
name [Char]
digest [Char]
cliSpecification)

-- | Every submission survives; concurrent writers, lost nodes and repeated creates halt.
haltsAttributably :: Theorem ClientObligation
haltsAttributably :: Theorem ClientObligation
haltsAttributably =
    [Char] -> [Char] -> Theorem ClientObligation
obligationRow
        [Char]
"R299-05"
        [Char]
"0c79da4ca0f30b7e225d13cceff5ea6e4cf92cd2b197cdf267f35754ef3bfb47"

-- | Submissions and partial state survive interruption; nothing is resubmitted.
partialSurvives :: Theorem ClientObligation
partialSurvives :: Theorem ClientObligation
partialSurvives =
    [Char] -> [Char] -> Theorem ClientObligation
obligationRow
        [Char]
"INV299-PARTIAL"
        [Char]
"3dc6a0b02d40eb86f251b9451729c3d55a1a37fadfb624153956819944c745eb"

-- | A leaf is reported only against the observed commitment.
authenticated :: Theorem ClientObligation
authenticated :: Theorem ClientObligation
authenticated =
    [Char] -> [Char] -> Theorem ClientObligation
obligationRow
        [Char]
"INV299-AUTHENTICATED"
        [Char]
"f35b175f8df8140f9a947178c375c1627864d4fa91fd39cc14234ee95b17b2aa"

-- | The state token, release, network and selected key bind every write and read.
identityBinds :: Theorem ClientObligation
identityBinds :: Theorem ClientObligation
identityBinds =
    [Char] -> [Char] -> Theorem ClientObligation
obligationRow
        [Char]
"INV299-IDENTITY"
        [Char]
"4ca4b7b81ec111c58ea1d066d60cd89adbd7ad8b7c363710ec58b9531c3ac982"

-- | An unavailable read never prints confirmed status.
readOnly :: Theorem ClientObligation
readOnly :: Theorem ClientObligation
readOnly =
    [Char] -> [Char] -> Theorem ClientObligation
obligationRow
        [Char]
"INV299-READONLY"
        [Char]
"ada685ce0cafbdaaa2c0c500d26bf53c51d990c851108cc3e7b802257c3fe6d8"

-- | The clause an indexer's read is told under.
indexerTitle :: Indexer -> String
indexerTitle :: Indexer -> [Char]
indexerTitle Indexer
ix =
    Indexer -> [Char]
indexerName Indexer
ix
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" finds exactly one output holding exactly one of the key's token, and its output, datum bytes, datum hash and chain position are the node's"

{- | Active becomes Terminal using its actual holding; a terminate the key's
entry rules out is refused before anything is signed.
-}
terminateBurnsActiveHolding :: Theorem ClientObligation
terminateBurnsActiveHolding :: Theorem ClientObligation
terminateBurnsActiveHolding =
    [Char] -> [Char] -> Theorem ClientObligation
obligationRow
        [Char]
"terminate-burns-active-holding"
        [Char]
"5ad24c43c629647d99afd7ddfe08f231f094ce0b07efb6ca819df1c131f288e8"

-- | An indexer's read of the Active key counts only when it agrees with the node.
indexerReads :: Theorem ClientObligation
indexerReads :: Theorem ClientObligation
indexerReads =
    [Char] -> [Char] -> Theorem ClientObligation
obligationRow
        [Char]
"INV300-INDEXER"
        [Char]
"3b78a7a63946e3d2796c9d4792f7c2bf451762a2909019bc3166ee7614dedd70"

-- | The client obligations the controls bind.
obligationBindings :: [Binding]
obligationBindings :: [BoundObligation]
obligationBindings =
    [ Theorem ClientObligation -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ClientObligation
haltsAttributably
    , Theorem ClientObligation -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ClientObligation
partialSurvives
    , Theorem ClientObligation -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ClientObligation
authenticated
    , Theorem ClientObligation -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ClientObligation
identityBinds
    , Theorem ClientObligation -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ClientObligation
readOnly
    , Theorem ClientObligation -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ClientObligation
indexerReads
    , Theorem ClientObligation -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem ClientObligation
terminateBurnsActiveHolding
    ]

{- | Whether the CLI's specification carries the bound row exactly once,
its line hashing (by the given SHA-256) to the bound digest.
-}
resolveObligation
    :: (Text -> Text) -> Text -> Binding -> Either String ()
resolveObligation :: (Text -> Text) -> Text -> BoundObligation -> Either [Char] ()
resolveObligation Text -> Text
sha256 Text
specification BoundObligation
b =
    case [ Text
l
         | Text
l <- Text -> [Text]
T.lines Text
specification
         , let firstCell :: Text
firstCell = case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"|" Text
l) of
                Text
cell : [Text]
_ -> Text -> Text
T.strip Text
cell
                [] -> Text
""
         , Text
firstCell Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
T.pack (BoundObligation -> [Char]
boName BoundObligation
b)
            Bool -> Bool -> Bool
|| (Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (BoundObligation -> [Char]
boName BoundObligation
b) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") Text -> Text -> Bool
`T.isSuffixOf` Text
firstCell
         ] of
        [Text
l]
            | Text -> Text
sha256 Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
T.pack (BoundObligation -> [Char]
boDigest BoundObligation
b) -> () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
            | Bool
otherwise ->
                [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left
                    ( BoundObligation -> [Char]
boName BoundObligation
b
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": the specification's row hashes to "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Text -> Text
sha256 Text
l)
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not the bound "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> BoundObligation -> [Char]
boDigest BoundObligation
b
                    )
        [] -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left (BoundObligation -> [Char]
boName BoundObligation
b [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": not a row of " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
cliSpecification)
        [Text]
_ -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left (BoundObligation -> [Char]
boName BoundObligation
b [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": more than one row of " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
cliSpecification)

{- | Whether the application's statement ledger (@ledgers.json@) carries
the bound statement under the bound digest, proved.
-}
resolveStatement :: Aeson.Value -> Binding -> Either String ()
resolveStatement :: Value -> BoundObligation -> Either [Char] ()
resolveStatement Value
ledger BoundObligation
b = do
    rows <- case Value -> Result LedgerFile
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
ledger of
        Aeson.Success (LedgerFile [LedgerRow]
r) -> [LedgerRow] -> Either [Char] [LedgerRow]
forall a b. b -> Either a b
Right [LedgerRow]
r
        Aeson.Error [Char]
e -> [Char] -> Either [Char] [LedgerRow]
forall a b. a -> Either a b
Left ([Char]
"the statement ledger does not parse: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
e)
    case [r | r <- rows, lrStatement r == T.pack (boName b)] of
        [LedgerRow
r]
            | LedgerRow -> Text
lrDigest LedgerRow
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char] -> Text
T.pack (BoundObligation -> [Char]
boDigest BoundObligation
b) ->
                [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left
                    ( BoundObligation -> [Char]
boName BoundObligation
b
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": the ledger's digest is "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (LedgerRow -> Text
lrDigest LedgerRow
r)
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not the bound "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> BoundObligation -> [Char]
boDigest BoundObligation
b
                    )
            | LedgerRow -> Text
lrStatus LedgerRow
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"PROVED" ->
                [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left (BoundObligation -> [Char]
boName BoundObligation
b [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": the ledger says " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (LedgerRow -> Text
lrStatus LedgerRow
r))
            | Bool
otherwise -> () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
        [] -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left (BoundObligation -> [Char]
boName BoundObligation
b [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": not in the statement ledger")
        [LedgerRow]
_ ->
            [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left (BoundObligation -> [Char]
boName BoundObligation
b [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": listed more than once in the statement ledger")

newtype LedgerFile = LedgerFile [LedgerRow]

data LedgerRow = LedgerRow
    { LedgerRow -> Text
lrStatement :: Text
    , LedgerRow -> Text
lrDigest :: Text
    , LedgerRow -> Text
lrStatus :: Text
    }

instance FromJSON LedgerFile where
    parseJSON :: Value -> Parser LedgerFile
parseJSON = [Char]
-> (Object -> Parser LedgerFile) -> Value -> Parser LedgerFile
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"ledgers" ((Object -> Parser LedgerFile) -> Value -> Parser LedgerFile)
-> (Object -> Parser LedgerFile) -> Value -> Parser LedgerFile
forall a b. (a -> b) -> a -> b
$ \Object
o -> [LedgerRow] -> LedgerFile
LedgerFile ([LedgerRow] -> LedgerFile)
-> Parser [LedgerRow] -> Parser LedgerFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [LedgerRow]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"theorems"

instance FromJSON LedgerRow where
    parseJSON :: Value -> Parser LedgerRow
parseJSON = [Char] -> (Object -> Parser LedgerRow) -> Value -> Parser LedgerRow
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"theorem" ((Object -> Parser LedgerRow) -> Value -> Parser LedgerRow)
-> (Object -> Parser LedgerRow) -> Value -> Parser LedgerRow
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text -> Text -> Text -> LedgerRow
LedgerRow
            (Text -> Text -> Text -> LedgerRow)
-> Parser Text -> Parser (Text -> Text -> LedgerRow)
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
"statement"
            Parser (Text -> Text -> LedgerRow)
-> Parser Text -> Parser (Text -> LedgerRow)
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
"statementSha256"
            Parser (Text -> LedgerRow) -> Parser Text -> Parser LedgerRow
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
"status"

-- ---------------------------------------------------------
-- The stories
-- ---------------------------------------------------------

requirement
    :: Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
requirement :: forall {k} (thm :: k).
Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
requirement Theorem thm
thm Requirement
req = Theorem thm
-> ([Receipt] -> Story CliI ()) -> LeanCheck CliI thm [Receipt]
forall {k} (thm :: k) obs (act :: * -> *).
Theorem thm -> (obs -> Story act ()) -> LeanCheck act thm obs
bindCheck Theorem thm
thm (CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (CliI () -> Story CliI ())
-> ([Receipt] -> CliI ()) -> [Receipt] -> Story CliI ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Requirement -> [Receipt] -> CliI ()
Require Requirement
req)

-- | The key the registry already holds, and the key it has never held.
heldKey, freshKey :: String
heldKey :: [Char]
heldKey = [Char]
"held"
freshKey :: [Char]
freshKey = [Char]
"fresh"

{- | The premise a telling builds on: the ordinary commands that bring a
key to its state, each of which must succeed, then a fresh reading of that
exact key in that registry. A premise that does not hold leaves every later
clause of the telling uncovered.
-}
premiseClause
    :: Theorem thm
    -> String
    -> Requirement
    -> Story [Receipt]
    -> TheoremStory thm CliI [Receipt]
premiseClause :: forall {k} (thm :: k).
Theorem thm
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
premiseClause Theorem thm
thm [Char]
title Requirement
req = [Char]
-> LeanCheck CliI thm [Receipt]
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause [Char]
title (Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
forall {k} (thm :: k).
Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
requirement Theorem thm
thm Requirement
req)

{- | Create a registry and bring 'heldKey' to Active with the ordinary
commands — and, when asked, to Terminal — then inspect it.
-}
reach :: Bool -> Target -> Story [Receipt]
reach :: Bool -> Target -> Story [Receipt]
reach Bool
terminal Target
target = do
    created <- CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Command -> Target -> [Char] -> CliI Receipt
Run Command
Create Target
target [Char]
"")
    inserted <- action (Run Insert target heldKey)
    terminated <-
        if terminal
            then pure <$> action (Run Terminate target heldKey)
            else pure []
    seen <- action (Run Inspect target heldKey)
    pure ([created, inserted] <> terminated <> [seen])

{- | The shared shape of both refusals, after their premise. On the control
registry, an absent key booked through the application and folded without
local evaluation is accepted. On the target, the held key booked through
the permissive builders is accepted, and that request's fold, submitted
without local evaluation, is refused by the registry's state validator:
the chain's own refusal, with nothing changed. The ordinary @insert@ of
the held key never gets that far: it is refused at booking before
signing, naming the key and the client policy, and the registry, its
pending requests and the wallet are unchanged by that early refusal.
-}
refusal
    :: Theorem thm
    -> Requirement
    -> String
    -> Target
    -> Target
    -> String
    -> String
    -> TheoremStory thm CliI ()
refusal :: forall {k} (thm :: k).
Theorem thm
-> Requirement
-> [Char]
-> Target
-> Target
-> [Char]
-> [Char]
-> TheoremStory thm CliI ()
refusal Theorem thm
thm Requirement
reachedReq [Char]
premiseTitle Target
control Target
target [Char]
keyWhat [Char]
refusedPhrase = do
    _ <-
        [Char]
-> LeanCheck CliI thm ([Receipt], [Receipt])
-> Story CliI ([Receipt], [Receipt])
-> TheoremStory thm CliI ([Receipt], [Receipt])
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
            [Char]
premiseTitle
            ( Theorem thm
-> (([Receipt], [Receipt]) -> Story CliI ())
-> LeanCheck CliI thm ([Receipt], [Receipt])
forall {k} (thm :: k) obs (act :: * -> *).
Theorem thm -> (obs -> Story act ()) -> LeanCheck act thm obs
bindCheck Theorem thm
thm ((([Receipt], [Receipt]) -> Story CliI ())
 -> LeanCheck CliI thm ([Receipt], [Receipt]))
-> (([Receipt], [Receipt]) -> Story CliI ())
-> LeanCheck CliI thm ([Receipt], [Receipt])
forall a b. (a -> b) -> a -> b
$ \([Receipt]
controlPrefix, [Receipt]
targetPrefix) -> do
                CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
reachedReq [Receipt]
controlPrefix)
                CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
reachedReq [Receipt]
targetPrefix)
            )
            ( do
                controlPrefix <- Bool -> Target -> Story [Receipt]
reach (Requirement
reachedReq Requirement -> Requirement -> Bool
forall a. Eq a => a -> a -> Bool
== Requirement
ReachedTerminal) Target
control
                targetPrefix <- reach (reachedReq == ReachedTerminal) target
                pure (controlPrefix, targetPrefix)
            )
    _ <-
        clause
            "an absent key, booked through the application and folded without local evaluation, is accepted"
            (requirement thm Accepted)
            ( do
                booking <- action (Book control freshKey)
                _ <- action (Require Accepted [booking])
                fold <- action (FoldUnevaluated control freshKey)
                pure [fold]
            )
    _ <-
        clause
            (keyWhat <> " booked through the permissive builders is accepted")
            (requirement thm Accepted)
            (pure <$> action (Book target heldKey))
    chainBefore <-
        clause
            "the registry, its pending requests and the wallet are read back"
            (bindCheck thm (\Receipt
r -> CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Observed [Receipt
r])))
            (action (Observe target heldKey))
    _ <-
        clause
            "that request's fold, submitted without local evaluation, is refused by the registry's state validator"
            (requirement thm RefusedByState)
            (pure <$> action (FoldUnevaluated target heldKey))
    chainPair <-
        clause
            "the registry's root, the key's holding, the pending request and the wallet are unchanged"
            (requirement thm Unchanged)
            ( do
                after <- action (Observe target heldKey)
                pure [chainBefore, after]
            )
    let chainAfter = case [Receipt]
chainPair of
            [Receipt
_, Receipt
afterChain] -> Receipt
afterChain
            [Receipt]
_ -> Receipt
chainBefore
    _ <-
        clause
            ( "the ordinary insert of "
                <> keyWhat
                <> " is refused before signing, naming the key "
                <> refusedPhrase
            )
            ( bindCheck
                thm
                (\(Receipt
cli, Receipt
observed) -> CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
BookingRefused [Receipt
cli, Receipt
observed]))
            )
            ( do
                cli <- action (Run Insert target heldKey)
                observed <- action (Observe target heldKey)
                pure (cli, observed)
            )
    _ <-
        clause
            "the registry's root, its pending requests and the wallet are unchanged by the booking refusal"
            (requirement thm RegistryUnchanged)
            ( do
                after <- action (Observe target heldKey)
                pure [chainAfter, after]
            )
    pure ()

-- | A second insertion of an Active key.
duplicateStory :: Story ()
duplicateStory :: Story CliI ()
duplicateStory =
    Theorem DuplicateRefused
-> TheoremStory DuplicateRefused CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem DuplicateRefused
duplicateRefused (TheoremStory DuplicateRefused CliI () -> Story CliI ())
-> TheoremStory DuplicateRefused CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$
        Theorem DuplicateRefused
-> Requirement
-> [Char]
-> Target
-> Target
-> [Char]
-> [Char]
-> TheoremStory DuplicateRefused CliI ()
forall {k} (thm :: k).
Theorem thm
-> Requirement
-> [Char]
-> Target
-> Target
-> [Char]
-> [Char]
-> TheoremStory thm CliI ()
refusal
            Theorem DuplicateRefused
duplicateRefused
            Requirement
ReachedActive
            [Char]
"the key reached Active through the ordinary commands, in the control registry and in the target, and inspect reads it Active in each"
            ([Char] -> Target
Target [Char]
"duplicate-control")
            ([Char] -> Target
Target [Char]
"duplicate")
            [Char]
"the Active key"
            [Char]
"already registered"

-- | An insertion of a key already Terminal.
resurrectionStory :: Story ()
resurrectionStory :: Story CliI ()
resurrectionStory =
    Theorem ResurrectionRefused
-> TheoremStory ResurrectionRefused CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem ResurrectionRefused
resurrectionRefused (TheoremStory ResurrectionRefused CliI () -> Story CliI ())
-> TheoremStory ResurrectionRefused CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$
        Theorem ResurrectionRefused
-> Requirement
-> [Char]
-> Target
-> Target
-> [Char]
-> [Char]
-> TheoremStory ResurrectionRefused CliI ()
forall {k} (thm :: k).
Theorem thm
-> Requirement
-> [Char]
-> Target
-> Target
-> [Char]
-> [Char]
-> TheoremStory thm CliI ()
refusal
            Theorem ResurrectionRefused
resurrectionRefused
            Requirement
ReachedTerminal
            [Char]
"the key reached Terminal through the ordinary commands, in the control registry and in the target, and inspect reads it Terminal in each"
            ([Char] -> Target
Target [Char]
"resurrection-control")
            ([Char] -> Target
Target [Char]
"resurrection")
            [Char]
"the Terminal key"
            [Char]
"already retired"

{- | Alice's story through the ordinary commands, judged against the
receipts the commands print: create, insert, inspect, two updates with
unrelated payloads, terminate, inspect.
-}
lifecycleStory :: Story ()
lifecycleStory :: Story CliI ()
lifecycleStory = do
    let target :: Target
target = [Char] -> Target
Target [Char]
"lifecycle"
        alice :: [Char]
alice = [Char]
"alice"
    inserted <-
        Theorem InsertionHoldingInline
-> TheoremStory
     InsertionHoldingInline CliI (Receipt, Receipt, Receipt)
-> Story CliI (Receipt, Receipt, Receipt)
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem InsertionHoldingInline
insertionHoldingInline (TheoremStory
   InsertionHoldingInline CliI (Receipt, Receipt, Receipt)
 -> Story CliI (Receipt, Receipt, Receipt))
-> TheoremStory
     InsertionHoldingInline CliI (Receipt, Receipt, Receipt)
-> Story CliI (Receipt, Receipt, Receipt)
forall a b. (a -> b) -> a -> b
$
            [Char]
-> LeanCheck
     CliI InsertionHoldingInline (Receipt, Receipt, Receipt)
-> Story CliI (Receipt, Receipt, Receipt)
-> TheoremStory
     InsertionHoldingInline CliI (Receipt, Receipt, Receipt)
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
                [Char]
"the ordinary insert delivers the key's one token to the application, under the inserted envelope inline, in the registry create booted"
                ( Theorem InsertionHoldingInline
-> ((Receipt, Receipt, Receipt) -> Story CliI ())
-> LeanCheck
     CliI InsertionHoldingInline (Receipt, Receipt, Receipt)
forall {k} (thm :: k) obs (act :: * -> *).
Theorem thm -> (obs -> Story act ()) -> LeanCheck act thm obs
bindCheck Theorem InsertionHoldingInline
insertionHoldingInline (((Receipt, Receipt, Receipt) -> Story CliI ())
 -> LeanCheck
      CliI InsertionHoldingInline (Receipt, Receipt, Receipt))
-> ((Receipt, Receipt, Receipt) -> Story CliI ())
-> LeanCheck
     CliI InsertionHoldingInline (Receipt, Receipt, Receipt)
forall a b. (a -> b) -> a -> b
$ \(Receipt
created, Receipt
ins, Receipt
seen) -> do
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
SameRegistry [Receipt
created, Receipt
ins])
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Delivered [Receipt
ins, Receipt
seen])
                )
                ( do
                    created <- CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Command -> Target -> [Char] -> CliI Receipt
Run Command
Create Target
target [Char]
"")
                    ins <- action (Run Insert target alice)
                    seen <- action (Run Inspect target alice)
                    pure (created, ins, seen)
                )
    let (_, _, afterInsert) = inserted
    afterFirst <-
        theorem updateKeepsRegistry $
            clause
                "the controller's update replaces the payload; the registry's root does not move"
                ( bindCheck updateKeepsRegistry $ \(Receipt
before, Receipt
upd, Receipt
after) ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
PayloadReplaced [Receipt
before, Receipt
upd, Receipt
after])
                )
                ( do
                    upd <- action (Run (Update 1) target alice)
                    after <- action (Run Inspect target alice)
                    pure (afterInsert, upd, after)
                )
    let (_, _, afterUpdate) = afterFirst
    afterSecond <-
        theorem updatePayloadFree $
            clause
                "a second update with an unrelated payload is accepted the same way"
                ( bindCheck updatePayloadFree $ \(Receipt
before, Receipt
upd, Receipt
after) ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
PayloadReplaced [Receipt
before, Receipt
upd, Receipt
after])
                )
                ( do
                    upd <- action (Run (Update 2) target alice)
                    after <- action (Run Inspect target alice)
                    pure (afterUpdate, upd, after)
                )
    let (_, _, beforeTerminate) = afterSecond
    theorem releaseBurnsAtomically $
        void $
            clause
                "the ordinary terminate burns the key's token and releases its protected deposit; the key reads Terminal"
                ( bindCheck releaseBurnsAtomically $ \(Receipt
before, Receipt
term, Receipt
after) ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Released [Receipt
before, Receipt
term, Receipt
after])
                )
                ( do
                    term <- action (Run Terminate target alice)
                    after <- action (Run Inspect target alice)
                    pure (beforeTerminate, term, after)
                )

{- | The application's own boundary, reached by hand-built transactions the
node judges: the controller's update beside an update required of another
wallet, the Aiken suite's custody tampers realisable on a ledger, and a
release outside any fold beside the ordinary terminate.
-}
boundaryStory :: Story ()
boundaryStory :: Story CliI ()
boundaryStory = do
    let target :: Target
target = [Char] -> Target
Target [Char]
"boundary"
    Theorem UpdateRequiresController
-> TheoremStory UpdateRequiresController CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem UpdateRequiresController
updateRequiresController (TheoremStory UpdateRequiresController CliI () -> Story CliI ())
-> TheoremStory UpdateRequiresController CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <-
            Theorem UpdateRequiresController
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory UpdateRequiresController CliI [Receipt]
forall {k} (thm :: k).
Theorem thm
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
premiseClause
                Theorem UpdateRequiresController
updateRequiresController
                [Char]
"the key reached Active through the ordinary commands, and inspect reads it Active"
                Requirement
ReachedActive
                (Bool -> Target -> Story [Receipt]
reach Bool
False Target
target)
        _ <-
            clause
                "the controller's own update, built by hand and submitted without local evaluation, is accepted"
                (requirement updateRequiresController Accepted)
                (pure <$> action (Craft HonestUpdate target heldKey))
        before <- readback updateRequiresController target
        _ <-
            clause
                "the same update, requiring another wallet's signature instead of the controller's, is refused by the application"
                (requirement updateRequiresController RefusedByApplication)
                (pure <$> action (Craft UpdateByStranger target heldKey))
        _ <-
            clause
                "the same update without the application's script is rejected before any script runs, and is not counted as a refusal"
                (requirement updateRequiresController RejectedBeforeScripts)
                (pure <$> action (Craft UpdateWithoutScript target heldKey))
        unchangedAfter updateRequiresController target before
    Theorem UpdatePreservesCustody
-> TheoremStory UpdatePreservesCustody CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem UpdatePreservesCustody
updatePreservesCustody (TheoremStory UpdatePreservesCustody CliI () -> Story CliI ())
-> TheoremStory UpdatePreservesCustody CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <- Theorem UpdatePreservesCustody
-> Target -> TheoremStory UpdatePreservesCustody CliI [Receipt]
forall {k} (thm :: k).
Theorem thm -> Target -> TheoremStory thm CliI [Receipt]
stillActive Theorem UpdatePreservesCustody
updatePreservesCustody Target
target
        _ <-
            clause
                "another controller's update, built the same way, is accepted"
                (requirement updatePreservesCustody Accepted)
                (pure <$> action (Craft HonestUpdate target heldKey))
        before <- readback updatePreservesCustody target
        forM_ tampers $ \Crafted
c ->
            [Char]
-> LeanCheck CliI UpdatePreservesCustody [Receipt]
-> Story [Receipt]
-> TheoremStory UpdatePreservesCustody CliI [Receipt]
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
                (Crafted -> [Char]
craftedPhrase Crafted
c [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is refused by the application")
                (Theorem UpdatePreservesCustody
-> Requirement -> LeanCheck CliI UpdatePreservesCustody [Receipt]
forall {k} (thm :: k).
Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
requirement Theorem UpdatePreservesCustody
updatePreservesCustody Requirement
RefusedByApplication)
                (Receipt -> [Receipt]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Receipt -> [Receipt]) -> Story CliI Receipt -> Story [Receipt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Crafted -> Target -> [Char] -> CliI Receipt
Craft Crafted
c Target
target [Char]
heldKey))
        unchangedAfter updatePreservesCustody target before
    Theorem OnlyFoldReleases
-> TheoremStory OnlyFoldReleases CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem OnlyFoldReleases
onlyFoldReleases (TheoremStory OnlyFoldReleases CliI () -> Story CliI ())
-> TheoremStory OnlyFoldReleases CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <- Theorem OnlyFoldReleases
-> Target -> TheoremStory OnlyFoldReleases CliI [Receipt]
forall {k} (thm :: k).
Theorem thm -> Target -> TheoremStory thm CliI [Receipt]
stillActive Theorem OnlyFoldReleases
onlyFoldReleases Target
target
        before <- readback onlyFoldReleases target
        _ <-
            clause
                "a release of the live holding outside any fold is refused by the application"
                (requirement onlyFoldReleases RefusedByApplication)
                (pure <$> action (Craft EarlyWithdrawal target heldKey))
        unchangedAfter onlyFoldReleases target before
        void $
            clause
                "the same holding, released inside the registry's fold by the ordinary terminate, is accepted"
                (requirement onlyFoldReleases CommandSucceeded)
                (pure <$> action (Run Terminate target heldKey))
  where
    tampers :: [Crafted]
tampers =
        [ Crafted
UpdateOtherController
        , Crafted
UpdateDepositTampered
        , Crafted
UpdateEscaped
        , Crafted
UpdateTokenLeft
        , Crafted
UpdateShortDeposit
        , Crafted
UpdateWithoutDatum
        , Crafted
UpdateAddedAsset
        ]
    readback :: Theorem thm -> Target -> TheoremStory thm CliI Receipt
    readback :: forall {k} (thm :: k).
Theorem thm -> Target -> TheoremStory thm CliI Receipt
readback Theorem thm
thm Target
target =
        [Char]
-> LeanCheck CliI thm Receipt
-> Story CliI Receipt
-> TheoremStory thm CliI Receipt
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
            [Char]
"the registry, the key's holding and the wallet are read back"
            (Theorem thm
-> (Receipt -> Story CliI ()) -> LeanCheck CliI thm Receipt
forall {k} (thm :: k) obs (act :: * -> *).
Theorem thm -> (obs -> Story act ()) -> LeanCheck act thm obs
bindCheck Theorem thm
thm (\Receipt
r -> CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Observed [Receipt
r])))
            (CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Target -> [Char] -> CliI Receipt
Observe Target
target [Char]
heldKey))
    unchangedAfter
        :: Theorem thm -> Target -> Receipt -> TheoremStory thm CliI ()
    unchangedAfter :: forall {k} (thm :: k).
Theorem thm -> Target -> Receipt -> TheoremStory thm CliI ()
unchangedAfter Theorem thm
thm Target
target Receipt
before =
        TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ())
-> TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ()
forall a b. (a -> b) -> a -> b
$
            [Char]
-> LeanCheck CliI thm [Receipt]
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
                [Char]
"the registry's root, the key's holding and the wallet are unchanged by every refusal"
                (Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
forall {k} (thm :: k).
Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
requirement Theorem thm
thm Requirement
HoldingUnchanged)
                ( do
                    after <- CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Target -> [Char] -> CliI Receipt
Observe Target
target [Char]
heldKey)
                    pure [before, after]
                )

-- | Read back the registry, a key's holding and the wallet, in a clause.
readbackOf
    :: Theorem thm -> Target -> String -> TheoremStory thm CliI Receipt
readbackOf :: forall {k} (thm :: k).
Theorem thm -> Target -> [Char] -> TheoremStory thm CliI Receipt
readbackOf Theorem thm
thm Target
target [Char]
key =
    [Char]
-> LeanCheck CliI thm Receipt
-> Story CliI Receipt
-> TheoremStory thm CliI Receipt
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
        [Char]
"the registry, its pending requests and the wallet are read back"
        (Theorem thm
-> (Receipt -> Story CliI ()) -> LeanCheck CliI thm Receipt
forall {k} (thm :: k) obs (act :: * -> *).
Theorem thm -> (obs -> Story act ()) -> LeanCheck act thm obs
bindCheck Theorem thm
thm (\Receipt
r -> CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Observed [Receipt
r])))
        (CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Target -> [Char] -> CliI Receipt
Observe Target
target [Char]
key))

-- | Read back again and require the given agreement with the first readback.
unchangedOf
    :: Theorem thm
    -> Requirement
    -> String
    -> Target
    -> String
    -> Receipt
    -> TheoremStory thm CliI ()
unchangedOf :: forall {k} (thm :: k).
Theorem thm
-> Requirement
-> [Char]
-> Target
-> [Char]
-> Receipt
-> TheoremStory thm CliI ()
unchangedOf Theorem thm
thm Requirement
req [Char]
title Target
target [Char]
key Receipt
before =
    TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ())
-> TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ()
forall a b. (a -> b) -> a -> b
$
        [Char]
-> LeanCheck CliI thm [Receipt]
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
            [Char]
title
            (Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
forall {k} (thm :: k).
Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
requirement Theorem thm
thm Requirement
req)
            ( do
                after <- CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Target -> [Char] -> CliI Receipt
Observe Target
target [Char]
key)
                pure [before, after]
            )

{- | The clause that bounds what a refused transaction put at risk, told after
the refusal it follows: the operator's explicit allowance is on the receipt,
the body states its total collateral within it and returns the rest.
-}
exposureBounded
    :: Theorem thm -> [Receipt] -> TheoremStory thm CliI ()
exposureBounded :: forall {k} (thm :: k).
Theorem thm -> [Receipt] -> TheoremStory thm CliI ()
exposureBounded Theorem thm
thm [Receipt]
refused =
    TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ())
-> TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ()
forall a b. (a -> b) -> a -> b
$
        [Char]
-> LeanCheck CliI thm [Receipt]
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
            [Char]
"the refused transaction states its collateral within the operator's explicit allowance and returns the rest of its funding output"
            (Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
forall {k} (thm :: k).
Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
requirement Theorem thm
thm Requirement
ExposureBounded)
            ([Receipt] -> Story [Receipt]
forall a. a -> ProgramT (Step CliI) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Receipt]
refused)

-- | One refusal clause for a crafted transaction, by its phrase.
refusedCraft
    :: Theorem thm -> Crafted -> Target -> String -> TheoremStory thm CliI ()
refusedCraft :: forall {k} (thm :: k).
Theorem thm
-> Crafted -> Target -> [Char] -> TheoremStory thm CliI ()
refusedCraft Theorem thm
thm Crafted
c Target
target [Char]
key =
    TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ())
-> TheoremStory thm CliI [Receipt] -> TheoremStory thm CliI ()
forall a b. (a -> b) -> a -> b
$
        [Char]
-> LeanCheck CliI thm [Receipt]
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
            (Crafted -> [Char]
craftedPhrase Crafted
c [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is refused by the application")
            (Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
forall {k} (thm :: k).
Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
requirement Theorem thm
thm Requirement
RefusedByApplication)
            (Receipt -> [Receipt]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Receipt -> [Receipt]) -> Story CliI Receipt -> Story [Receipt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Crafted -> Target -> [Char] -> CliI Receipt
Craft Crafted
c Target
target [Char]
key))

{- | Bookings the application must refuse, beside a booking it certifies:
the controller's envelope booked by another wallet, a request naming
another destination or no datum, a short request deposit, and envelopes
naming another registry's state asset. Each refused booking leaves the
registry, its pending requests and the wallet as they were.
-}
bookingStory :: Story ()
bookingStory :: Story CliI ()
bookingStory = do
    let target :: Target
target = [Char] -> Target
Target [Char]
"booking"
    created <- Theorem BookInsertInversion
-> TheoremStory BookInsertInversion CliI [Receipt]
-> Story [Receipt]
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem BookInsertInversion
bookInsertInversion (TheoremStory BookInsertInversion CliI [Receipt]
 -> Story [Receipt])
-> TheoremStory BookInsertInversion CliI [Receipt]
-> Story [Receipt]
forall a b. (a -> b) -> a -> b
$ do
        created <-
            Theorem BookInsertInversion
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory BookInsertInversion CliI [Receipt]
forall {k} (thm :: k).
Theorem thm
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
premiseClause
                Theorem BookInsertInversion
bookInsertInversion
                [Char]
"the registry was created by the ordinary command"
                Requirement
Established
                (Receipt -> [Receipt]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Receipt -> [Receipt]) -> Story CliI Receipt -> Story [Receipt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Command -> Target -> [Char] -> CliI Receipt
Run Command
Create Target
target [Char]
""))
        _ <-
            clause
                "an insertion booked through the application by the controller is accepted"
                (requirement bookInsertInversion Accepted)
                (pure <$> action (Book target "booked"))
        before <- readbackOf bookInsertInversion target "booked"
        refusedCraft
            bookInsertInversion
            BookingByStranger
            target
            "by-stranger"
        refusedCraft
            bookInsertInversion
            BookingOtherDestination
            target
            "other-destination"
        refusedCraft
            bookInsertInversion
            BookingShortDeposit
            target
            "short-deposit"
        refusedCraft bookInsertInversion BookingNoDatum target "no-datum"
        unchangedOf
            bookInsertInversion
            RegistryUnchanged
            "the registry's root, its pending requests and the wallet are unchanged by every refusal"
            target
            "booked"
            before
        pure created
    theorem insertionRequiresRegistryIdentity $ do
        _ <-
            premiseClause
                insertionRequiresRegistryIdentity
                "the same registry, created by the ordinary command"
                Established
                (pure created)
        _ <-
            clause
                "an envelope naming this registry, booked the same way, is accepted"
                (requirement insertionRequiresRegistryIdentity Accepted)
                (pure <$> action (Book target "named"))
        before <- readbackOf insertionRequiresRegistryIdentity target "named"
        refusedCraft
            insertionRequiresRegistryIdentity
            EnvelopeOtherStateName
            target
            "other-name"
        refusedCraft
            insertionRequiresRegistryIdentity
            EnvelopeOtherStatePolicy
            target
            "other-policy"
        refusedCraft
            insertionRequiresRegistryIdentity
            EnvelopeOtherRegistry
            target
            "other-registry"
        unchangedOf
            insertionRequiresRegistryIdentity
            RegistryUnchanged
            "the registry's root, its pending requests and the wallet are unchanged by every refusal"
            target
            "named"
            before

{- | A termination and its fold. A stranger's termination booking is
refused beside the controller's own; the terminating fold paying the
controller one lovelace short is refused beside the same fold paying in
full; and a fold of another request that also releases a live holding is
refused beside the same fold without the release.
-}
settlementStory :: Story ()
settlementStory :: Story CliI ()
settlementStory = do
    let target :: Target
target = [Char] -> Target
Target [Char]
"settlement"
    Theorem BookTerminateInversion
-> TheoremStory BookTerminateInversion CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem BookTerminateInversion
bookTerminateInversion (TheoremStory BookTerminateInversion CliI () -> Story CliI ())
-> TheoremStory BookTerminateInversion CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <-
            [Char]
-> LeanCheck CliI BookTerminateInversion ([Receipt], [Receipt])
-> Story CliI ([Receipt], [Receipt])
-> TheoremStory BookTerminateInversion CliI ([Receipt], [Receipt])
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
                [Char]
"two keys reached Active through the ordinary commands, and inspect reads each Active"
                ( Theorem BookTerminateInversion
-> (([Receipt], [Receipt]) -> Story CliI ())
-> LeanCheck CliI BookTerminateInversion ([Receipt], [Receipt])
forall {k} (thm :: k) obs (act :: * -> *).
Theorem thm -> (obs -> Story act ()) -> LeanCheck act thm obs
bindCheck Theorem BookTerminateInversion
bookTerminateInversion ((([Receipt], [Receipt]) -> Story CliI ())
 -> LeanCheck CliI BookTerminateInversion ([Receipt], [Receipt]))
-> (([Receipt], [Receipt]) -> Story CliI ())
-> LeanCheck CliI BookTerminateInversion ([Receipt], [Receipt])
forall a b. (a -> b) -> a -> b
$ \([Receipt]
heldPrefix, [Receipt]
otherPrefix) -> do
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
ReachedActive [Receipt]
heldPrefix)
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
ReachedActive [Receipt]
otherPrefix)
                )
                ( do
                    heldPrefix <- Bool -> Target -> Story [Receipt]
reach Bool
False Target
target
                    inserted <- action (Run Insert target otherKey)
                    seen <- action (Run Inspect target otherKey)
                    pure (heldPrefix, [inserted, seen])
                )
        before <- readbackOf bookTerminateInversion target heldKey
        refusedCraft
            bookTerminateInversion
            TerminateBookingByStranger
            target
            heldKey
        unchangedOf
            bookTerminateInversion
            RegistryUnchanged
            "the registry's root, its pending requests and the wallet are unchanged by the refusal"
            target
            heldKey
            before
        void $
            clause
                "the controller's own termination booking is accepted"
                (requirement bookTerminateInversion Accepted)
                (pure <$> action (Craft TerminateBooking target heldKey))
    Theorem FoldSettlesAdditively
-> TheoremStory FoldSettlesAdditively CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem FoldSettlesAdditively
foldSettlesAdditively (TheoremStory FoldSettlesAdditively CliI () -> Story CliI ())
-> TheoremStory FoldSettlesAdditively CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <- Theorem FoldSettlesAdditively
-> Target -> TheoremStory FoldSettlesAdditively CliI [Receipt]
forall {k} (thm :: k).
Theorem thm -> Target -> TheoremStory thm CliI [Receipt]
stillActive Theorem FoldSettlesAdditively
foldSettlesAdditively Target
target
        before <- readbackOf foldSettlesAdditively target heldKey
        refusedCraft foldSettlesAdditively FoldPaysShort target heldKey
        unchangedOf
            foldSettlesAdditively
            HoldingUnchanged
            "the registry's root, the key's holding and the wallet are unchanged by the refusal"
            target
            heldKey
            before
        _ <-
            clause
                "the same terminating fold, folded by another wallet, paying the controller in full, is accepted"
                (requirement foldSettlesAdditively Accepted)
                (pure <$> action (Craft FoldPaysInFull target heldKey))
        -- One controller, two releases in one fold; then an insertion and a
        -- termination in one fold. Each short payment is refused beside the
        -- same fold paid in full, and neither refusal moves anything.
        let batch = [Char] -> Target
Target [Char]
"batch"
        _ <-
            clause
                "a second registry holds three of the controller's keys Active, and inspect reads each Active"
                ( bindCheck foldSettlesAdditively $ \([Receipt]
first, [[Receipt]]
others) -> do
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
ReachedActive [Receipt]
first)
                    ([Receipt] -> Story CliI ()) -> [[Receipt]] -> Story CliI ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (CliI () -> Story CliI ())
-> ([Receipt] -> CliI ()) -> [Receipt] -> Story CliI ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Requirement -> [Receipt] -> CliI ()
Require Requirement
ReachedActive) [[Receipt]]
others
                )
                ( do
                    created <- action (Run Create batch "")
                    pairs <-
                        mapM
                            ( \[Char]
k -> do
                                inserted <- CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Command -> Target -> [Char] -> CliI Receipt
Run Command
Insert Target
batch [Char]
k)
                                seen <- action (Run Inspect batch k)
                                pure [inserted, seen]
                            )
                            ["pair-a", "pair-b", "mixed-old"]
                    case pairs of
                        ([Receipt]
p : [[Receipt]]
ps) -> ([Receipt], [[Receipt]]) -> Story CliI ([Receipt], [[Receipt]])
forall a. a -> ProgramT (Step CliI) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Receipt
created Receipt -> [Receipt] -> [Receipt]
forall a. a -> [a] -> [a]
: [Receipt]
p, [[Receipt]]
ps)
                        [] -> ([Receipt], [[Receipt]]) -> Story CliI ([Receipt], [[Receipt]])
forall a. a -> ProgramT (Step CliI) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Receipt
created], [])
                )
        _ <-
            clause
                "the controller's terminations of two keys are booked"
                ( bindCheck foldSettlesAdditively $ \[Receipt]
bs ->
                    (Receipt -> Story CliI ()) -> [Receipt] -> Story CliI ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Receipt
b -> CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Accepted [Receipt
b])) [Receipt]
bs
                )
                ( mapM
                    (action . Craft TerminateBooking batch)
                    ["pair-a", "pair-b"]
                )
        pairBefore <-
            clause
                "the registry, the first key's holding and the wallet are read back before the two-release fold"
                (bindCheck foldSettlesAdditively (\Receipt
r -> CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Observed [Receipt
r])))
                (action (Observe batch "pair-a"))
        refusedCraft foldSettlesAdditively FoldTwoReleasesShort batch "pair-a"
        refusedCraft
            foldSettlesAdditively
            FoldTwoReleasesOneFloor
            batch
            "pair-a"
        unchangedOf
            foldSettlesAdditively
            HoldingUnchanged
            "the registry's root, the first key's holding and the wallet are unchanged by both refusals"
            batch
            "pair-a"
            pairBefore
        _ <-
            clause
                "the two-release fold paying the controller the sum in full is accepted"
                (requirement foldSettlesAdditively Accepted)
                (pure <$> action (Craft FoldTwoReleasesInFull batch "pair-a"))
        _ <-
            clause
                "an insertion of a new key and the termination of another are booked for the controller"
                ( bindCheck foldSettlesAdditively $ \[Receipt]
bs ->
                    (Receipt -> Story CliI ()) -> [Receipt] -> Story CliI ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Receipt
b -> CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Accepted [Receipt
b])) [Receipt]
bs
                )
                ( do
                    inserted <- action (Book batch "mixed-new")
                    terminated <- action (Craft TerminateBooking batch "mixed-old")
                    pure [inserted, terminated]
                )
        mixedBefore <-
            clause
                "the registry, the terminated key's holding and the wallet are read back before the mixed fold"
                (bindCheck foldSettlesAdditively (\Receipt
r -> CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Observed [Receipt
r])))
                (action (Observe batch "mixed-old"))
        refusedCraft foldSettlesAdditively FoldMixedShort batch "mixed-old"
        unchangedOf
            foldSettlesAdditively
            HoldingUnchanged
            "the registry's root, the terminated key's holding and the wallet are unchanged by the refusal"
            batch
            "mixed-old"
            mixedBefore
        void $
            clause
                "the mixed fold paying the controller in full is accepted"
                (requirement foldSettlesAdditively Accepted)
                (pure <$> action (Craft FoldMixedInFull batch "mixed-old"))
    Theorem FoldInversion
-> TheoremStory FoldInversion CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem FoldInversion
foldInversion (TheoremStory FoldInversion CliI () -> Story CliI ())
-> TheoremStory FoldInversion CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <-
            Theorem FoldInversion
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory FoldInversion CliI [Receipt]
forall {k} (thm :: k).
Theorem thm
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
premiseClause
                Theorem FoldInversion
foldInversion
                [Char]
"the other key still reads Active, from a readback whose public replay agrees with the chain's root"
                Requirement
ReachedActive
                (Receipt -> [Receipt]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Receipt -> [Receipt]) -> Story CliI Receipt -> Story [Receipt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Target -> [Char] -> CliI Receipt
Observe Target
target [Char]
otherKey))
        _ <-
            clause
                "an insertion of an absent key, booked through the application, is accepted"
                (requirement foldInversion Accepted)
                (pure <$> action (Book target freshKey))
        before <- readbackOf foldInversion target otherKey
        refusedCraft foldInversion ReleaseInOtherFold target otherKey
        unchangedOf
            foldInversion
            HoldingUnchanged
            "the registry's root, the other key's holding and the wallet are unchanged by the refusal"
            target
            otherKey
            before
        void $
            clause
                "the same fold, without the release, is accepted"
                (requirement foldInversion Accepted)
                (pure <$> action (FoldUnevaluated target freshKey))
  where
    otherKey :: [Char]
otherKey = [Char]
"other"

{- | Bob's update and terminate refused before signing, beside Alice's same
verbs accepted on a live key. One registry holds a key Active, one key
Terminal, and one key it never held: Bob, from an empty directory naming the
registry only by its state token, has an update or a terminate of the unknown
or the Terminal key refused at booking, naming the key and the client policy,
before anything is signed; Alice's same verbs on the Active key are accepted,
the update replacing the payload with the root unmoved and the terminate
releasing the deposit. The refusals are the client's own policy with no Lean
theorem claimed; only the accepted payload update is told under
`update_inversion`, which states exactly that accepted step.
-}
earlyRefusalStory :: Story ()
earlyRefusalStory :: Story CliI ()
earlyRefusalStory = do
    let target :: Target
target = [Char] -> Target
Target [Char]
"refusals"
        live :: [Char]
live = [Char]
"live"
        ended :: [Char]
ended = [Char]
"ended"
        fresh :: [Char]
fresh = [Char]
"fresh"
        bob :: Target
bob = [Char] -> Target
Target [Char]
"bob"
    (accB, accU, accA) <- Theorem ClientPolicy
-> TheoremStory ClientPolicy CliI (Receipt, Receipt, Receipt)
-> Story CliI (Receipt, Receipt, Receipt)
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem ClientPolicy
earlyRefusalPolicy (TheoremStory ClientPolicy CliI (Receipt, Receipt, Receipt)
 -> Story CliI (Receipt, Receipt, Receipt))
-> TheoremStory ClientPolicy CliI (Receipt, Receipt, Receipt)
-> Story CliI (Receipt, Receipt, Receipt)
forall a b. (a -> b) -> a -> b
$ do
        _ <-
            [Char]
-> LeanCheck
     CliI
     ClientPolicy
     (Receipt, Receipt, Receipt, Receipt, Receipt, Receipt)
-> Story
     CliI (Receipt, Receipt, Receipt, Receipt, Receipt, Receipt)
-> TheoremStory
     ClientPolicy
     CliI
     (Receipt, Receipt, Receipt, Receipt, Receipt, Receipt)
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
                [Char]
"one key reached Active and another Terminal through the ordinary commands, and inspect reads each"
                ( Theorem ClientPolicy
-> ((Receipt, Receipt, Receipt, Receipt, Receipt, Receipt)
    -> Story CliI ())
-> LeanCheck
     CliI
     ClientPolicy
     (Receipt, Receipt, Receipt, Receipt, Receipt, Receipt)
forall {k} (thm :: k) obs (act :: * -> *).
Theorem thm -> (obs -> Story act ()) -> LeanCheck act thm obs
bindCheck Theorem ClientPolicy
earlyRefusalPolicy (((Receipt, Receipt, Receipt, Receipt, Receipt, Receipt)
  -> Story CliI ())
 -> LeanCheck
      CliI
      ClientPolicy
      (Receipt, Receipt, Receipt, Receipt, Receipt, Receipt))
-> ((Receipt, Receipt, Receipt, Receipt, Receipt, Receipt)
    -> Story CliI ())
-> LeanCheck
     CliI
     ClientPolicy
     (Receipt, Receipt, Receipt, Receipt, Receipt, Receipt)
forall a b. (a -> b) -> a -> b
$ \(Receipt
c, Receipt
li, Receipt
en, Receipt
et, Receipt
ls, Receipt
es) -> do
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Established [Receipt
c])
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
ReachedActive [Receipt
li, Receipt
ls])
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
ReachedTerminal [Receipt
en, Receipt
et, Receipt
es])
                )
                ( do
                    c <- CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Command -> Target -> [Char] -> CliI Receipt
Run Command
Create Target
target [Char]
"")
                    li <- action (Run Insert target live)
                    ls <- action (Run Inspect target live)
                    en <- action (Run Insert target ended)
                    et <- action (Run Terminate target ended)
                    es <- action (Run Inspect target ended)
                    pure (c, li, en, et, ls, es)
                )
        before <- readbackOf earlyRefusalPolicy target live
        _ <-
            clause
                "Bob's update of the unknown key is refused before signing, naming the key not registered"
                ( bindCheck earlyRefusalPolicy $ \(Receipt
cli, Receipt
seen) ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
BookingRefused [Receipt
cli, Receipt
seen])
                )
                ( do
                    cli <- action (RunByToken bob target (Update 1) fresh)
                    seen <- action (Observe target fresh)
                    pure (cli, seen)
                )
        _ <-
            clause
                "Bob's update of the Terminal key is refused before signing, naming the key already retired"
                ( bindCheck earlyRefusalPolicy $ \(Receipt
cli, Receipt
seen) ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
BookingRefused [Receipt
cli, Receipt
seen])
                )
                ( do
                    cli <- action (RunByToken bob target (Update 1) ended)
                    seen <- action (Observe target ended)
                    pure (cli, seen)
                )
        _ <-
            clause
                "the registry's root, the key's holding and the wallet are unchanged by the booking refusal"
                (requirement earlyRefusalPolicy HoldingUnchanged)
                ( do
                    after <- action (Observe target live)
                    pure [before, after]
                )
        (b, u, a) <-
            clause
                "the controller's update of the Active key, replacing the payload with the root unmoved, is accepted"
                ( bindCheck earlyRefusalPolicy $ \(Receipt
b, Receipt
u, Receipt
a) -> do
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
CommandSucceeded [Receipt
u])
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
PayloadReplaced [Receipt
b, Receipt
u, Receipt
a])
                )
                ( do
                    b <- action (Run Inspect target live)
                    u <- action (Run (Update 2) target live)
                    a <- action (Run Inspect target live)
                    pure (b, u, a)
                )
        pure (b, u, a)
    theorem updateInversion $ do
        void $
            clause
                "the accepted update replaces the payload with the root unmoved (update_inversion)"
                ( bindCheck updateInversion $ \(Receipt
b, Receipt
u, Receipt
a) -> do
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
CommandSucceeded [Receipt
u])
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
PayloadReplaced [Receipt
b, Receipt
u, Receipt
a])
                )
                (pure (accB, accU, accA))
    theorem terminateBurnsActiveHolding $ do
        _ <-
            premiseClause
                terminateBurnsActiveHolding
                "the live key still reads Active, from a fresh inspect"
                ReachedActive
                (pure <$> action (Run Inspect target live))
        before <- readbackOf terminateBurnsActiveHolding target live
        _ <-
            clause
                "Bob's terminate of the unknown key is refused before signing, naming the key not registered"
                ( bindCheck terminateBurnsActiveHolding $ \(Receipt
cli, Receipt
seen) ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
BookingRefused [Receipt
cli, Receipt
seen])
                )
                ( do
                    cli <- action (RunByToken bob target Terminate fresh)
                    seen <- action (Observe target fresh)
                    pure (cli, seen)
                )
        _ <-
            clause
                "Bob's terminate of the Terminal key is refused before signing, naming the key already retired"
                ( bindCheck terminateBurnsActiveHolding $ \(Receipt
cli, Receipt
seen) ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
BookingRefused [Receipt
cli, Receipt
seen])
                )
                ( do
                    cli <- action (RunByToken bob target Terminate ended)
                    seen <- action (Observe target ended)
                    pure (cli, seen)
                )
        _ <-
            clause
                "the registry's root, the key's holding and the wallet are unchanged by the booking refusal"
                (requirement terminateBurnsActiveHolding HoldingUnchanged)
                ( do
                    after <- action (Observe target live)
                    pure [before, after]
                )
        void $
            clause
                "the controller's terminate of the Active key, releasing its deposit, is accepted"
                ( bindCheck terminateBurnsActiveHolding $ \(Receipt
b, Receipt
t, Receipt
a) -> do
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
CommandSucceeded [Receipt
t])
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Released [Receipt
b, Receipt
t, Receipt
a])
                )
                ( do
                    b <- action (Run Inspect target live)
                    t <- action (Run Terminate target live)
                    a <- action (Run Inspect target live)
                    pure (b, t, a)
                )

controlsStory :: Story ()
controlsStory :: Story CliI ()
controlsStory =
    Story CliI ()
duplicateStory
        Story CliI () -> Story CliI () -> Story CliI ()
forall a b.
ProgramT (Step CliI) Identity a
-> ProgramT (Step CliI) Identity b
-> ProgramT (Step CliI) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Story CliI ()
resurrectionStory
        Story CliI () -> Story CliI () -> Story CliI ()
forall a b.
ProgramT (Step CliI) Identity a
-> ProgramT (Step CliI) Identity b
-> ProgramT (Step CliI) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Story CliI ()
earlyRefusalStory
        Story CliI () -> Story CliI () -> Story CliI ()
forall a b.
ProgramT (Step CliI) Identity a
-> ProgramT (Step CliI) Identity b
-> ProgramT (Step CliI) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Story CliI ()
lifecycleStory
        Story CliI () -> Story CliI () -> Story CliI ()
forall a b.
ProgramT (Step CliI) Identity a
-> ProgramT (Step CliI) Identity b
-> ProgramT (Step CliI) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Story CliI ()
boundaryStory
        Story CliI () -> Story CliI () -> Story CliI ()
forall a b.
ProgramT (Step CliI) Identity a
-> ProgramT (Step CliI) Identity b
-> ProgramT (Step CliI) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Story CliI ()
bookingStory
        Story CliI () -> Story CliI () -> Story CliI ()
forall a b.
ProgramT (Step CliI) Identity a
-> ProgramT (Step CliI) Identity b
-> ProgramT (Step CliI) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Story CliI ()
settlementStory
        Story CliI () -> Story CliI () -> Story CliI ()
forall a b.
ProgramT (Step CliI) Identity a
-> ProgramT (Step CliI) Identity b
-> ProgramT (Step CliI) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Story CliI ()
processStory

{- | One take on a registry that already exists, through a node someone else
runs: the four refusals the demonstration shows, each beside its accepting
control, on one fresh key.

The key is inserted by the ordinary command, which is also the accepting
control of the two insertion refusals; a second insertion of the Active key is
refused before signing, naming the key already registered, with nothing
submitted and nothing to retract; the update another wallet's signature stands
for is refused, beside the controller's own ordinary update; a release outside
any fold is refused, beside the ordinary terminate that releases the same
holding inside one; an insertion of the now Terminal key is refused before
signing, naming the key already retired, likewise with nothing to retract.

No registry is created and no node is started, stopped or reset: the story
contains none of those actions, which 'forbiddenInPermanent' names.
-}
permanentStory :: String -> Story ()
permanentStory :: [Char] -> Story CliI ()
permanentStory [Char]
key = do
    let target :: Target
target = [Char] -> Target
Target [Char]
"permanent"
        again :: [Char]
again =
            [Char]
"the ordinary insert of the Active key is refused before signing, naming the key already registered"
        unchanged :: [Char]
unchanged =
            [Char]
"the registry's root, its pending requests and the wallet are unchanged by the booking refusal"
        absent :: [Char]
absent = [Char]
"the ordinary insert of the absent key is accepted"
    inserted <- Theorem DuplicateRefused
-> TheoremStory DuplicateRefused CliI Receipt -> Story CliI Receipt
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem DuplicateRefused
duplicateRefused (TheoremStory DuplicateRefused CliI Receipt -> Story CliI Receipt)
-> TheoremStory DuplicateRefused CliI Receipt -> Story CliI Receipt
forall a b. (a -> b) -> a -> b
$ do
        opened <-
            [Char]
-> LeanCheck CliI DuplicateRefused (Receipt, Receipt)
-> Story CliI (Receipt, Receipt)
-> TheoremStory DuplicateRefused CliI (Receipt, Receipt)
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
                [Char]
"the key reached Active through the ordinary insert, and inspect reads it Active"
                ( Theorem DuplicateRefused
-> ((Receipt, Receipt) -> Story CliI ())
-> LeanCheck CliI DuplicateRefused (Receipt, Receipt)
forall {k} (thm :: k) obs (act :: * -> *).
Theorem thm -> (obs -> Story act ()) -> LeanCheck act thm obs
bindCheck Theorem DuplicateRefused
duplicateRefused (((Receipt, Receipt) -> Story CliI ())
 -> LeanCheck CliI DuplicateRefused (Receipt, Receipt))
-> ((Receipt, Receipt) -> Story CliI ())
-> LeanCheck CliI DuplicateRefused (Receipt, Receipt)
forall a b. (a -> b) -> a -> b
$ \(Receipt
ins, Receipt
seen) ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
ReachedActive [Receipt
ins, Receipt
seen])
                )
                ( do
                    ins <- CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Command -> Target -> [Char] -> CliI Receipt
Run Command
Insert Target
target [Char]
key)
                    seen <- action (Run Inspect target key)
                    pure (ins, seen)
                )
        let (ins, _) = opened
        _ <-
            clause
                absent
                (requirement duplicateRefused CommandSucceeded)
                (pure [ins])
        refusedInsertion duplicateRefused target key again unchanged
        pure ins
    finalInspect <- theorem updateRequiresController $ do
        _ <-
            premiseClause
                updateRequiresController
                "the key still reads Active, from a fresh inspect"
                ReachedActive
                (pure <$> action (Run Inspect target key))
        before <- readbackOf updateRequiresController target key
        refusedUpdate <-
            clause
                "the same update, requiring another wallet's signature instead of the controller's, is refused by the application"
                (requirement updateRequiresController RefusedByApplication)
                (pure <$> action (Craft UpdateByStranger target key))
        exposureBounded updateRequiresController refusedUpdate
        unchangedOf
            updateRequiresController
            HoldingUnchanged
            "the registry's root, the key's holding and the wallet are unchanged by the refusal"
            target
            key
            before
        (_, _, final) <-
            clause
                "the controller's own update, by the ordinary command, is accepted"
                ( bindCheck updateRequiresController $ \(Receipt
b, Receipt
u, Receipt
a) ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
PayloadReplaced [Receipt
b, Receipt
u, Receipt
a])
                )
                ( do
                    b <- action (Run Inspect target key)
                    u <- action (Run (Update 2) target key)
                    a <- action (Run Inspect target key)
                    pure (b, u, a)
                )
        pure final
    theorem indexerReads $ do
        _ <-
            premiseClause
                indexerReads
                "the key still reads Active, from the fresh inspect that follows its final update"
                ReachedActive
                (pure [finalInspect])
        forM_ [minBound .. maxBound :: Indexer] $ \Indexer
ix ->
            [Char]
-> LeanCheck CliI ClientObligation [Receipt]
-> Story [Receipt]
-> TheoremStory ClientObligation CliI [Receipt]
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
                (Indexer -> [Char]
indexerTitle Indexer
ix)
                (Theorem ClientObligation
-> Requirement -> LeanCheck CliI ClientObligation [Receipt]
forall {k} (thm :: k).
Theorem thm -> Requirement -> LeanCheck CliI thm [Receipt]
requirement Theorem ClientObligation
indexerReads Requirement
IndexerAgrees)
                ( do
                    r <- CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Indexer -> Target -> [Char] -> Receipt -> CliI Receipt
ReadIndexer Indexer
ix Target
target [Char]
key Receipt
finalInspect)
                    pure [finalInspect, r]
                )
    terminated <- theorem onlyFoldReleases $ do
        _ <-
            premiseClause
                onlyFoldReleases
                "the key still reads Active, from a fresh inspect"
                ReachedActive
                (pure <$> action (Run Inspect target key))
        before <- readbackOf onlyFoldReleases target key
        refusedRelease <-
            clause
                "a release of the live holding outside any fold is refused by the application"
                (requirement onlyFoldReleases RefusedByApplication)
                (pure <$> action (Craft EarlyWithdrawal target key))
        exposureBounded onlyFoldReleases refusedRelease
        unchangedOf
            onlyFoldReleases
            HoldingUnchanged
            "the registry's root, the key's holding and the wallet are unchanged by the refusal"
            target
            key
            before
        clause
            "the same holding, released inside the registry's fold by the ordinary terminate, is accepted"
            (requirement onlyFoldReleases CommandSucceeded)
            (pure <$> action (Run Terminate target key))
    theorem resurrectionRefused $ do
        _ <-
            premiseClause
                resurrectionRefused
                "the key reached Terminal through the ordinary commands, and inspect reads it Terminal"
                ReachedTerminal
                ( do
                    seen <- action (Run Inspect target key)
                    pure (terminated <> [seen])
                )
        _ <-
            clause
                absent
                (requirement resurrectionRefused CommandSucceeded)
                (pure [inserted])
        refusedInsertion
            resurrectionRefused
            target
            key
            "the ordinary insert of the Terminal key is refused before signing, naming the key already retired"
            unchanged

{- | A second insertion of a key the registry holds, refused at booking
before signing: the ordinary command names the key and the client
policy, submits nothing, and leaves no pending request behind, so
there is no fold and nothing to retract.
-}
refusedInsertion
    :: Theorem thm
    -> Target
    -> String
    -> String
    -> String
    -> TheoremStory thm CliI ()
refusedInsertion :: forall {k} (thm :: k).
Theorem thm
-> Target -> [Char] -> [Char] -> [Char] -> TheoremStory thm CliI ()
refusedInsertion Theorem thm
thm Target
target [Char]
key [Char]
again [Char]
unchanged = do
    bookingBefore <-
        [Char]
-> LeanCheck CliI thm Receipt
-> Story CliI Receipt
-> TheoremStory thm CliI Receipt
forall {k} (act :: * -> *) (thm :: k) obs.
[Char]
-> LeanCheck act thm obs
-> Story act obs
-> TheoremStory thm act obs
clause
            [Char]
"the registry, its pending requests and the wallet are read back before the booking refusal"
            (Theorem thm
-> (Receipt -> Story CliI ()) -> LeanCheck CliI thm Receipt
forall {k} (thm :: k) obs (act :: * -> *).
Theorem thm -> (obs -> Story act ()) -> LeanCheck act thm obs
bindCheck Theorem thm
thm (\Receipt
r -> CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
Observed [Receipt
r])))
            (CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Target -> [Char] -> CliI Receipt
Observe Target
target [Char]
key))
    _ <-
        clause
            again
            ( bindCheck thm $ \(Receipt
cli, Receipt
observed) ->
                CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
BookingRefused [Receipt
cli, Receipt
observed])
            )
            ( do
                cli <- action (Run Insert target key)
                observed <- action (Observe target key)
                pure (cli, observed)
            )
    void $
        clause
            unchanged
            (requirement thm RegistryUnchanged)
            ( do
                after <- action (Observe target key)
                pure [bookingBefore, after]
            )

-- | The actions a story runs, by the name their receipts carry, in order.
actionsOf :: Story () -> [Text]
actionsOf :: Story CliI () -> [Text]
actionsOf = Story CliI () -> [Text]
forall a. Story a -> [Text]
go
  where
    go :: Story a -> [Text]
    go :: forall a. Story a -> [Text]
go Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
_ -> []
        Action CliI b
i :>>= b -> Story a
next -> CliI b -> [Text]
forall {res}. CliI res -> [Text]
names CliI b
i [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Story a -> [Text]
forall a. Story a -> [Text]
go (b -> Story a
next (CliI b -> b
forall a. CliI a -> a
blank CliI b
i))
        Theorem Theorem thm
_ TheoremStory thm CliI b
body :>>= b -> Story a
next -> Program (Clause thm CliI) b -> (b -> Story a) -> [Text]
forall {k} (thm :: k) b a.
Program (Clause thm CliI) b -> (b -> Story a) -> [Text]
inClauses (TheoremStory thm CliI b -> Program (Clause thm CliI) b
forall {k} (thm :: k) (act :: * -> *) res.
TheoremStory thm act res -> Program (Clause thm act) res
clauses TheoremStory thm CliI b
body) b -> Story a
next
    inClauses
        :: Program (Clause thm CliI) b -> (b -> Story a) -> [Text]
    inClauses :: forall {k} (thm :: k) b a.
Program (Clause thm CliI) b -> (b -> Story a) -> [Text]
inClauses Program (Clause thm CliI) b
p b -> Story a
k = case Program (Clause thm CliI) b -> ProgramView (Clause thm CliI) b
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Program (Clause thm CliI) b
p of
        Return b
b -> Story a -> [Text]
forall a. Story a -> [Text]
go (b -> Story a
k b
b)
        Clause [Char]
_ LeanCheck CliI thm b
leanCheck Story CliI b
body :>>= b -> Program (Clause thm CliI) b
next ->
            let obs :: b
obs = Story CliI b -> b
forall a. Story a -> a
resultOf Story CliI b
body
            in  Story CliI b -> [Text]
forall a. Story a -> [Text]
go Story CliI b
body [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Story CliI () -> [Text]
forall a. Story a -> [Text]
go (LeanCheck CliI thm b -> b -> Story CliI ()
forall {k} (act :: * -> *) (thm :: k) obs.
LeanCheck act thm obs -> obs -> Story act ()
checkAction LeanCheck CliI thm b
leanCheck b
obs) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Program (Clause thm CliI) b -> (b -> Story a) -> [Text]
forall {k} (thm :: k) b a.
Program (Clause thm CliI) b -> (b -> Story a) -> [Text]
inClauses (b -> Program (Clause thm CliI) b
next b
obs) b -> Story a
k
    names :: CliI res -> [Text]
names CliI res
i = [Text]
-> ((Text, Text, Text) -> [Text])
-> Maybe (Text, Text, Text)
-> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(Text
a, Text
_, Text
_) -> [Text
a]) (CliI res -> Maybe (Text, Text, Text)
forall res. CliI res -> Maybe (Text, Text, Text)
identify CliI res
i)
    resultOf :: Story a -> a
    resultOf :: forall a. Story a -> a
resultOf Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
a -> a
a
        Action CliI b
i :>>= b -> Story a
next -> Story a -> a
forall a. Story a -> a
resultOf (b -> Story a
next (CliI b -> b
forall a. CliI a -> a
blank CliI b
i))
        Theorem Theorem thm
_ TheoremStory thm CliI b
_ :>>= b -> Story a
_ -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"actionsOf: a statement nested inside a clause"
    blank :: CliI a -> a
    blank :: forall a. CliI a -> a
blank CliI a
i = case CliI a
i of
        Require Requirement
_ [Receipt]
_ -> ()
        Retire [Char]
_ -> ()
        Run{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        RunByToken{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Book{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        FoldUnevaluated{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Observe{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Craft{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Provoke{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Reclaim{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        ReadIndexer{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""

{- | What a take on an existing registry never does: create one, or provoke a
command by stopping a process or a node. Quantified over every command and
every provocation this module defines, so a provocation added later is
forbidden until a ruling admits it.
-}
forbiddenInPermanent :: [Text]
forbiddenInPermanent :: [Text]
forbiddenInPermanent =
    [Text
"run create"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"provoke " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Provocation -> [Char]
provocationName Provocation
p) | Provocation
p <- [Provocation
forall a. Bounded a => a
minBound .. Provocation
forall a. Bounded a => a
maxBound]
           ]

-- | Why the saved-selector promise is retired.
selectorRetired :: String
selectorRetired :: [Char]
selectorRetired =
    [Char]
"Retired: a registry is joined from its state token alone; there is no saved selector file to change."

{- | The client's obligations under conditions of its process, each told
under the row of the CLI's specification it bears on: a changed selector,
withheld public history and an absent node; a terminate and a create killed
once the node accepted them; and, last because it stops the node, a
concurrent writer, a racing create and an update that loses its node.
-}
processStory :: Story ()
processStory :: Story CliI ()
processStory = do
    let target :: Target
target = [Char] -> Target
Target [Char]
"process"
        interrupted :: Target
interrupted = [Char] -> Target
Target [Char]
"interrupted"
        raced :: Target
raced = [Char] -> Target
Target [Char]
"raced"
        second :: [Char]
second = [Char]
"second"
        third :: [Char]
third = [Char]
"third"
        reader :: Target
reader = [Char] -> Target
Target [Char]
"reader"
        reading :: [Char] -> [Char] -> Theorem thm -> TheoremStory thm CliI [Receipt]
reading [Char]
key [Char]
title Theorem thm
thm =
            Theorem thm
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
forall {k} (thm :: k).
Theorem thm
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
premiseClause
                Theorem thm
thm
                [Char]
title
                Requirement
ReachedActive
                (Receipt -> [Receipt]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Receipt -> [Receipt]) -> Story CliI Receipt -> Story [Receipt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Command -> Target -> [Char] -> CliI Receipt
Run Command
Inspect Target
target [Char]
key))
    Theorem ClientObligation
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem ClientObligation
identityBinds (TheoremStory ClientObligation CliI () -> Story CliI ())
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <-
            Theorem ClientObligation
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory ClientObligation CliI [Receipt]
forall {k} (thm :: k).
Theorem thm
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
premiseClause
                Theorem ClientObligation
identityBinds
                [Char]
"the key reached Active through the ordinary commands, and inspect reads it Active"
                Requirement
ReachedActive
                (Bool -> Target -> Story [Receipt]
reach Bool
False Target
target)
        _ <-
            clause
                "a second actor, starting from an empty directory with only the state token, reads the same registry"
                (requirement identityBinds TokenOnlyReading)
                ( do
                    mine <- action (Run Inspect target heldKey)
                    theirs <- action (RunByToken reader target Inspect heldKey)
                    pure [mine, theirs]
                )
        _ <-
            clause
                "a second actor, starting from an empty directory with only the state token, folds Alice's pending request and reads it Active"
                (requirement identityBinds FoldConsumed)
                ( do
                    booking <- action (Book target freshKey)
                    folded <- action (RunByToken reader target Fold freshKey)
                    seen <- action (RunByToken reader target Inspect freshKey)
                    pure [booking, folded, seen]
                )
        -- Retired by operator ruling: no command reads a saved selector. The
        -- second key is still inserted, for the clauses below that use it.
        _ <-
            clause
                "an insert with the saved application selector changed is refused before submitting"
                (requirement identityBinds RefusedBeforeSubmitting)
                ([] <$ action (Retire selectorRetired))
        void $
            clause
                "the same insert, with the selector restored, is accepted"
                (requirement identityBinds CommandSucceeded)
                ( action (Retire selectorRetired)
                    >> (pure <$> action (Run Insert target second))
                )
    Theorem ClientObligation
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem ClientObligation
authenticated (TheoremStory ClientObligation CliI () -> Story CliI ())
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <- [Char]
-> [Char]
-> Theorem ClientObligation
-> TheoremStory ClientObligation CliI [Receipt]
forall {k} {thm :: k}.
[Char] -> [Char] -> Theorem thm -> TheoremStory thm CliI [Receipt]
reading [Char]
heldKey [Char]
"inspect reads the key Active" Theorem ClientObligation
authenticated
        void $
            clause
                "inspect with the public history it needs withheld prints no leaf and names HistoryIncomplete"
                (requirement authenticated NoLeafPrinted)
                (pure <$> action (Provoke WithoutHistory target heldKey))
    Theorem ClientObligation
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem ClientObligation
readOnly (TheoremStory ClientObligation CliI () -> Story CliI ())
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <- [Char]
-> [Char]
-> Theorem ClientObligation
-> TheoremStory ClientObligation CliI [Receipt]
forall {k} {thm :: k}.
[Char] -> [Char] -> Theorem thm -> TheoremStory thm CliI [Receipt]
reading [Char]
heldKey [Char]
"inspect reads the key Active" Theorem ClientObligation
readOnly
        void $
            clause
                "inspect against a node socket that does not exist prints no leaf"
                (requirement readOnly NoLeafPrinted)
                (pure <$> action (Provoke WithoutNode target heldKey))
    Theorem ClientObligation
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem ClientObligation
partialSurvives (TheoremStory ClientObligation CliI () -> Story CliI ())
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <- [Char]
-> [Char]
-> Theorem ClientObligation
-> TheoremStory ClientObligation CliI [Receipt]
forall {k} {thm :: k}.
[Char] -> [Char] -> Theorem thm -> TheoremStory thm CliI [Receipt]
reading [Char]
heldKey [Char]
"inspect reads the key Active" Theorem ClientObligation
partialSurvives
        killed <-
            clause
                "a terminate killed once the node accepted its fold stopped there, its body kept"
                (requirement partialSurvives StoppedAfterAcceptance)
                (pure <$> action (Provoke TerminateKilled target heldKey))
        updated <-
            clause
                "an update of another key then reconciles the fold from the chain and proceeds, or, while the fold is not yet on chain, is refused before submitting, naming the fold and its case"
                ( bindCheck partialSurvives $ \[Receipt]
seen ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
ReconciledOrRefused (Int -> [Receipt] -> [Receipt]
forall a. Int -> [a] -> [a]
take Int
1 [Receipt]
killed [Receipt] -> [Receipt] -> [Receipt]
forall a. Semigroup a => a -> a -> a
<> [Receipt]
seen))
                )
                (pure <$> action (Provoke UpdateAfterKill target second))
        _ <-
            clause
                "inspect reads the key Terminal, the fold replayed at the chain root, never resubmitted and observed once across every receipt: the killed terminate's fold is accepted"
                ( bindCheck partialSurvives $ \Receipt
seen ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action
                        (Requirement -> [Receipt] -> CliI ()
Require Requirement
ResolvedFromChain (Int -> [Receipt] -> [Receipt]
forall a. Int -> [a] -> [a]
take Int
1 [Receipt]
killed [Receipt] -> [Receipt] -> [Receipt]
forall a. Semigroup a => a -> a -> a
<> Int -> [Receipt] -> [Receipt]
forall a. Int -> [a] -> [a]
take Int
1 [Receipt]
updated [Receipt] -> [Receipt] -> [Receipt]
forall a. Semigroup a => a -> a -> a
<> [Receipt
seen]))
                )
                (action (Run Inspect target heldKey))
        booted <-
            clause
                "a create killed once the node accepted its boot stopped there, its body kept"
                (requirement partialSurvives StoppedAfterAcceptance)
                (pure <$> action (Provoke CreateKilled interrupted ""))
        _ <-
            clause
                "a second create of that registry is refused before submitting"
                (requirement partialSurvives RefusedBeforeSubmitting)
                (pure <$> action (Provoke CreateAgain interrupted ""))
        void $
            clause
                "inspect reads the incomplete create from its journal and observes its boot, printing no leaf"
                ( bindCheck partialSurvives $ \Receipt
seen ->
                    CliI () -> Story CliI ()
forall (act :: * -> *) res. act res -> Story act res
action (Requirement -> [Receipt] -> CliI ()
Require Requirement
IncompleteCreateRead (Int -> [Receipt] -> [Receipt]
forall a. Int -> [a] -> [a]
take Int
1 [Receipt]
booted [Receipt] -> [Receipt] -> [Receipt]
forall a. Semigroup a => a -> a -> a
<> [Receipt
seen]))
                )
                (action (Run Inspect interrupted heldKey))
    Theorem ClientObligation
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall {k} (thm :: k) (act :: * -> *) res.
Theorem thm -> TheoremStory thm act res -> Story act res
theorem Theorem ClientObligation
haltsAttributably (TheoremStory ClientObligation CliI () -> Story CliI ())
-> TheoremStory ClientObligation CliI () -> Story CliI ()
forall a b. (a -> b) -> a -> b
$ do
        _ <-
            [Char]
-> [Char]
-> Theorem ClientObligation
-> TheoremStory ClientObligation CliI [Receipt]
forall {k} {thm :: k}.
[Char] -> [Char] -> Theorem thm -> TheoremStory thm CliI [Receipt]
reading [Char]
second [Char]
"inspect reads a second key Active" Theorem ClientObligation
haltsAttributably
        _ <-
            clause
                "an insert while another process holds the registry's lock is refused before submitting"
                (requirement haltsAttributably RefusedBeforeSubmitting)
                (pure <$> action (Provoke WhileLocked target third))
        _ <-
            clause
                "the same insert, once the lock is released, is accepted"
                (requirement haltsAttributably CommandSucceeded)
                (pure <$> action (Run Insert target third))
        _ <-
            clause
                "the same wallet starts create on the same seed twice; the second is held before the lock while the first completes, and is refused because the registry exists"
                (requirement haltsAttributably LateCreateRefused)
                (pure <$> action (Provoke LateCreate raced ""))
        _ <-
            clause
                "a create from a wallet that cannot fund every publication is refused before it submits anything, leaving its directory untouched and its seed unspent"
                (requirement haltsAttributably CreateUnderfunded)
                (pure <$> action (Provoke UnderfundedCreate raced ""))
        void $
            clause
                "an update held once the node accepted it, with the node stopped, ends within its bound naming its transaction"
                (requirement haltsAttributably BoundedAfterNodeLoss)
                (pure <$> action (Provoke NodeLost target second))

-- ---------------------------------------------------------
-- Receipts
-- ---------------------------------------------------------

-- | A readback of one registry, for one key.

{- | What a submitted transaction states about its fee and collateral, read
from the body the receipt retained and never from the receipt's own words:
only admission sets it.
-}
data Account = Account
    { Account -> Integer
acFee :: Integer
    , Account -> [Text]
acCollateralInputs :: [Text]
    , Account -> Maybe Integer
acCollateralTotal :: Maybe Integer
    -- ^ The total collateral the body declares, if it declares one
    , Account -> Maybe Integer
acCollateralReturn :: Maybe Integer
    -- ^ The lovelace of the collateral return the body declares, if any
    , Account -> [Text]
acSpends :: [Text]
    -- ^ The outputs the body spends, as output references
    }
    deriving stock (Account -> Account -> Bool
(Account -> Account -> Bool)
-> (Account -> Account -> Bool) -> Eq Account
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Account -> Account -> Bool
== :: Account -> Account -> Bool
$c/= :: Account -> Account -> Bool
/= :: Account -> Account -> Bool
Eq, Int -> Account -> ShowS
[Account] -> ShowS
Account -> [Char]
(Int -> Account -> ShowS)
-> (Account -> [Char]) -> ([Account] -> ShowS) -> Show Account
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Account -> ShowS
showsPrec :: Int -> Account -> ShowS
$cshow :: Account -> [Char]
show :: Account -> [Char]
$cshowList :: [Account] -> ShowS
showList :: [Account] -> ShowS
Show)

-- | A public indexer the take asks about its Active key.
data Indexer = Koios | Blockfrost
    deriving stock (Indexer -> Indexer -> Bool
(Indexer -> Indexer -> Bool)
-> (Indexer -> Indexer -> Bool) -> Eq Indexer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Indexer -> Indexer -> Bool
== :: Indexer -> Indexer -> Bool
$c/= :: Indexer -> Indexer -> Bool
/= :: Indexer -> Indexer -> Bool
Eq, Int -> Indexer -> ShowS
[Indexer] -> ShowS
Indexer -> [Char]
(Int -> Indexer -> ShowS)
-> (Indexer -> [Char]) -> ([Indexer] -> ShowS) -> Show Indexer
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Indexer -> ShowS
showsPrec :: Int -> Indexer -> ShowS
$cshow :: Indexer -> [Char]
show :: Indexer -> [Char]
$cshowList :: [Indexer] -> ShowS
showList :: [Indexer] -> ShowS
Show, Int -> Indexer
Indexer -> Int
Indexer -> [Indexer]
Indexer -> Indexer
Indexer -> Indexer -> [Indexer]
Indexer -> Indexer -> Indexer -> [Indexer]
(Indexer -> Indexer)
-> (Indexer -> Indexer)
-> (Int -> Indexer)
-> (Indexer -> Int)
-> (Indexer -> [Indexer])
-> (Indexer -> Indexer -> [Indexer])
-> (Indexer -> Indexer -> [Indexer])
-> (Indexer -> Indexer -> Indexer -> [Indexer])
-> Enum Indexer
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 :: Indexer -> Indexer
succ :: Indexer -> Indexer
$cpred :: Indexer -> Indexer
pred :: Indexer -> Indexer
$ctoEnum :: Int -> Indexer
toEnum :: Int -> Indexer
$cfromEnum :: Indexer -> Int
fromEnum :: Indexer -> Int
$cenumFrom :: Indexer -> [Indexer]
enumFrom :: Indexer -> [Indexer]
$cenumFromThen :: Indexer -> Indexer -> [Indexer]
enumFromThen :: Indexer -> Indexer -> [Indexer]
$cenumFromTo :: Indexer -> Indexer -> [Indexer]
enumFromTo :: Indexer -> Indexer -> [Indexer]
$cenumFromThenTo :: Indexer -> Indexer -> Indexer -> [Indexer]
enumFromThenTo :: Indexer -> Indexer -> Indexer -> [Indexer]
Enum, Indexer
Indexer -> Indexer -> Bounded Indexer
forall a. a -> a -> Bounded a
$cminBound :: Indexer
minBound :: Indexer
$cmaxBound :: Indexer
maxBound :: Indexer
Bounded)

indexerName :: Indexer -> String
indexerName :: Indexer -> [Char]
indexerName Indexer
ix = case Indexer
ix of
    Indexer
Koios -> [Char]
"koios"
    Indexer
Blockfrost -> [Char]
"blockfrost"

{- | What an indexer's readback record keeps, as read from the record's retained
bytes by admission and never from the receipt's own words: the policy and asset
name it was asked about, the provider's own answers counted into the outputs
that hold the token, the output, datum bytes and tip it reports, what the node
read, the maximum lag it was run under, and the summary it states. The verdict
recomputes every comparison from these facts; the stated summary is only checked
against them.
-}
data IndexerRead = IndexerRead
    { IndexerRead -> Text
irProvider :: Text
    , IndexerRead -> Text
irPolicy :: Text
    , IndexerRead -> Text
irAssetName :: Text
    , IndexerRead -> Maybe [(Text, Integer)]
irHolders :: Maybe [(Text, Integer)]
    {- ^ Every output the provider's answer says holds the token, with how many
    of it; nothing when the record keeps no such answer
    -}
    , IndexerRead -> Maybe Int
irHolderAddresses :: Maybe Int
    -- ^ How many addresses the provider's answer says hold the token (Blockfrost)
    , IndexerRead -> Maybe Text
irAnswerDatum :: Maybe Text
    -- ^ The inline datum bytes the provider's answer carries for its holder
    , IndexerRead -> Maybe Integer
irAnswerTip :: Maybe Integer
    -- ^ The tip slot the provider's own answer reports
    , IndexerRead -> Text
irIndexerOutput :: Text
    , IndexerRead -> Text
irIndexerDatumCbor :: Text
    , IndexerRead -> Text
irIndexerDatumHashRecorded :: Text
    -- ^ The hash the record says it recomputed from the indexer's datum
    , IndexerRead -> Maybe Text
irIndexerDatumHashComputed :: Maybe Text
    {- ^ The blake2b-256 of the indexer's datum bytes, computed by admission from
    the record's bytes; nothing until admitted, or when the bytes are not hex
    -}
    , IndexerRead -> Maybe Integer
irIndexerTipSlot :: Maybe Integer
    , IndexerRead -> Maybe Integer
irMaxLagSlots :: Maybe Integer
    , IndexerRead -> Text
irNodeOutput :: Text
    , IndexerRead -> Text
irNodeDatumCbor :: Text
    , IndexerRead -> Text
irNodeDatumHash :: Text
    , IndexerRead -> Text
irNodeChainPoint :: Text
    , IndexerRead -> Stated
irStated :: Stated
    , IndexerRead -> [Text]
irMalformed :: [Text]
    {- ^ Every whole-number fact the record keeps that is not an exact whole number
    of its domain, named with its raw value. A malformed quantity or index of an
    output holding the token withholds the provider's whole answer.
    -}
    }
    deriving stock (IndexerRead -> IndexerRead -> Bool
(IndexerRead -> IndexerRead -> Bool)
-> (IndexerRead -> IndexerRead -> Bool) -> Eq IndexerRead
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IndexerRead -> IndexerRead -> Bool
== :: IndexerRead -> IndexerRead -> Bool
$c/= :: IndexerRead -> IndexerRead -> Bool
/= :: IndexerRead -> IndexerRead -> Bool
Eq, Int -> IndexerRead -> ShowS
[IndexerRead] -> ShowS
IndexerRead -> [Char]
(Int -> IndexerRead -> ShowS)
-> (IndexerRead -> [Char])
-> ([IndexerRead] -> ShowS)
-> Show IndexerRead
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IndexerRead -> ShowS
showsPrec :: Int -> IndexerRead -> ShowS
$cshow :: IndexerRead -> [Char]
show :: IndexerRead -> [Char]
$cshowList :: [IndexerRead] -> ShowS
showList :: [IndexerRead] -> ShowS
Show)

{- | The domain a whole-number fact of a readback record lies in: a quantity or
a slot (0 to 2^64-1), an output index (0 to 65535), or a lag, negative when the
indexer is ahead of the node (within 64 signed bits).
-}
data Whole = Count | OutputIndex | Lag
    deriving stock (Whole -> Whole -> Bool
(Whole -> Whole -> Bool) -> (Whole -> Whole -> Bool) -> Eq Whole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Whole -> Whole -> Bool
== :: Whole -> Whole -> Bool
$c/= :: Whole -> Whole -> Bool
/= :: Whole -> Whole -> Bool
Eq, Int -> Whole -> ShowS
[Whole] -> ShowS
Whole -> [Char]
(Int -> Whole -> ShowS)
-> (Whole -> [Char]) -> ([Whole] -> ShowS) -> Show Whole
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Whole -> ShowS
showsPrec :: Int -> Whole -> ShowS
$cshow :: Whole -> [Char]
show :: Whole -> [Char]
$cshowList :: [Whole] -> ShowS
showList :: [Whole] -> ShowS
Show)

wholeBounds :: Whole -> (Integer, Integer)
wholeBounds :: Whole -> (Integer, Integer)
wholeBounds Whole
d = case Whole
d of
    Whole
Count -> (Integer
0, Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64
forall a. Bounded a => a
maxBound :: Word64))
    Whole
OutputIndex -> (Integer
0, Integer
65535)
    Whole
Lag -> (Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
minBound :: Int64), Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
maxBound :: Int64))

{- | A whole number of its domain, exactly, from a JSON number or the decimal
digits of one: a fraction is never rounded into one, and a number outside the
domain is not one.
-}
wholeIn :: Whole -> Aeson.Value -> Maybe Integer
wholeIn :: Whole -> Value -> Maybe Integer
wholeIn Whole
d Value
raw = do
    n <- case Value
raw of
        Aeson.Number Scientific
s -> case Whole
d of
            Whole
Lag -> Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> Integer) -> Maybe Int64 -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Scientific -> Maybe Int64
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Sci.toBoundedInteger Scientific
s :: Maybe Int64)
            Whole
_ -> Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> Maybe Word64 -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Scientific -> Maybe Word64
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Sci.toBoundedInteger Scientific
s :: Maybe Word64)
        Aeson.String Text
t -> case Text -> Maybe (Char, Text)
T.uncons Text
t of
            Just (Char
'-', Text
ds) | Whole
d Whole -> Whole -> Bool
forall a. Eq a => a -> a -> Bool
== Whole
Lag -> Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Integer
forall {b}. Read b => Text -> Maybe b
digits Text
ds
            Maybe (Char, Text)
_ -> Text -> Maybe Integer
forall {b}. Read b => Text -> Maybe b
digits Text
t
        Value
_ -> Maybe Integer
forall a. Maybe a
Nothing
    n <$ guard (lo <= n && n <= hi)
  where
    (Integer
lo, Integer
hi) = Whole -> (Integer, Integer)
wholeBounds Whole
d
    digits :: Text -> Maybe b
digits Text
ds = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Text -> Bool
T.null Text
ds) Bool -> Bool -> Bool
&& Text -> Int
T.length Text
ds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
20 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
ds)
        [Char] -> Maybe b
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
T.unpack Text
ds)

-- | A fact outside its domain, named with its raw value and the domain it misses.
notWhole :: Text -> Whole -> Aeson.Value -> Text
notWhole :: Text -> Whole -> Value -> Text
notWhole Text
what Whole
d Value
raw =
    Text
what
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 (LazyByteString -> ByteString
BL.toStrict (Value -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
Aeson.encode Value
raw))
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", not "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> case Whole
d of
            Whole
OutputIndex -> Text
"an exact output index from 0 to 65535"
            Whole
_ ->
                Text
"an exact whole number from "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
lo)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
hi)
  where
    (Integer
lo, Integer
hi) = Whole -> (Integer, Integer)
wholeBounds Whole
d

-- | The summary a readback record states about itself.
data Stated = Stated
    { Stated -> Bool
stHolds :: Bool
    , Stated -> Bool
stSameOutput :: Bool
    , Stated -> Bool
stSameDatumBytes :: Bool
    , Stated -> Bool
stSameDatumHash :: Bool
    , Stated -> Bool
stWithinLag :: Bool
    , Stated -> Maybe Integer
stLagSlots :: Maybe Integer
    }
    deriving stock (Stated -> Stated -> Bool
(Stated -> Stated -> Bool)
-> (Stated -> Stated -> Bool) -> Eq Stated
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Stated -> Stated -> Bool
== :: Stated -> Stated -> Bool
$c/= :: Stated -> Stated -> Bool
/= :: Stated -> Stated -> Bool
Eq, Int -> Stated -> ShowS
[Stated] -> ShowS
Stated -> [Char]
(Int -> Stated -> ShowS)
-> (Stated -> [Char]) -> ([Stated] -> ShowS) -> Show Stated
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Stated -> ShowS
showsPrec :: Int -> Stated -> ShowS
$cshow :: Stated -> [Char]
show :: Stated -> [Char]
$cshowList :: [Stated] -> ShowS
showList :: [Stated] -> ShowS
Show)

-- | The record the readback script writes, in the fields the verdict reads.
decodeIndexerRead :: Aeson.Value -> Maybe IndexerRead
decodeIndexerRead :: Value -> Maybe IndexerRead
decodeIndexerRead Value
v = do
    provider <- Value -> [Text] -> Maybe Text
str Value
v [Text
"provider"]
    policy <- str v ["policy"]
    name <- str v ["assetName"]
    holds <- bool ["holds"]
    sameOut <- bool ["comparisons", "sameOutput"]
    bytes <- bool ["comparisons", "sameDatumBytes"]
    hash <- bool ["comparisons", "sameDatumHash"]
    lagOk <- bool ["comparisons", "withinLag"]
    found <- str v ["indexer", "output"]
    cbor <- str v ["indexer", "datumCbor"]
    recomputed <- str v ["indexer", "datumHashRecomputed"]
    nodeOut <- str v ["inspect", "output"]
    nodeCbor <- str v ["inspect", "datumCbor"]
    nodeHash <- str v ["inspect", "datumHash"]
    point <- str v ["inspect", "observedTip"]
    let unit = Text
policy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
        answers =
            [ (Text
url, Value
response)
            | Just (Aeson.Array Array
rs) <- [Value -> [Text] -> Maybe Value
path Value
v [Text
"requests"]]
            , Value
r <- Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
rs
            , Just (Aeson.String Text
url) <- [Value -> [Text] -> Maybe Value
path Value
r [Text
"url"]]
            , Just (Aeson.Number Scientific
200) <- [Value -> [Text] -> Maybe Value
path Value
r [Text
"status"]]
            , Just Value
response <- [Value -> [Text] -> Maybe Value
path Value
r [Text
"response"]]
            ]
        lastAnswer Text -> Bool
p = case [Value
a | (Text
url, Value
a) <- [(Text, Value)]
answers, Text -> Bool
p Text
url] of
            [] -> Maybe Value
forall a. Maybe a
Nothing
            [Value]
as -> Value -> Maybe Value
forall a. a -> Maybe a
Just ([Value] -> Value
forall a. HasCallStack => [a] -> a
last [Value]
as)
        -- Every output of an answer, as its reference and how many of the token
        -- it holds, or the fact that makes it unreadable: an entry for the token
        -- whose quantity is not exact withholds the whole answer, and never drops
        -- out of the sum.
        census Text
what Text
entries Value -> Bool
matches Maybe Value
answer = case Maybe Value
answer of
            Just (Aeson.Array Array
os) -> case [Either Text (Text, Integer)] -> [Text]
forall a b. [Either a b] -> [a]
lefts [Either Text (Text, Integer)]
outputs of
                [] -> ([(Text, Integer)] -> Maybe [(Text, Integer)]
forall a. a -> Maybe a
Just ([Either Text (Text, Integer)] -> [(Text, Integer)]
forall a b. [Either a b] -> [b]
rights [Either Text (Text, Integer)]
outputs), [])
                [Text]
bad -> (Maybe [(Text, Integer)]
forall a. Maybe a
Nothing, [Text]
bad)
              where
                outputs :: [Either Text (Text, Integer)]
outputs = (Value -> Either Text (Text, Integer))
-> [Value] -> [Either Text (Text, Integer)]
forall a b. (a -> b) -> [a] -> [b]
map (Text
-> Text -> (Value -> Bool) -> Value -> Either Text (Text, Integer)
holding Text
what Text
entries Value -> Bool
matches) (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
os)
            Maybe Value
_ -> (Maybe [(Text, Integer)]
forall a. Maybe a
Nothing, [])
        holding Text
what Text
entries Value -> Bool
matches Value
o = do
            let tx :: Text
tx = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Value -> [Text] -> Maybe Text
str Value
o [Text
"tx_hash"])
                index :: Maybe Value
index = case Value -> [Text] -> Maybe Value
path Value
o [Text
"tx_index"] of
                    Just Value
i -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
i
                    Maybe Value
Nothing -> Value -> [Text] -> Maybe Value
path Value
o [Text
"output_index"]
            ix <- Text -> Whole -> Maybe Value -> Either Text (Maybe Integer)
whole (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'s output index of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tx) Whole
OutputIndex Maybe Value
index
            r <- case (str o ["tx_hash"], ix) of
                (Just Text
t, Just Integer
i) -> Text -> Either Text Text
forall a b. b -> Either a b
Right (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
i))
                (Maybe Text, Maybe Integer)
_ ->
                    Text -> Either Text Text
forall a b. a -> Either a b
Left (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" names an output without its transaction and index")
            qs <-
                traverse
                    (quantityAt r)
                    [ a
                    | Just (Aeson.Array as) <- [path o [entries]]
                    , a <- V.toList as
                    , matches a
                    ]
            pure (r, sum qs)
          where
            quantityAt :: Text -> Value -> Either Text Integer
quantityAt Text
r Value
a =
                Text -> Whole -> Maybe Value -> Either Text (Maybe Integer)
whole
                    (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'s quantity of the token at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r)
                    Whole
Count
                    (Value -> [Text] -> Maybe Value
path Value
a [Text
"quantity"])
                    Either Text (Maybe Integer)
-> (Maybe Integer -> Either Text Integer) -> Either Text Integer
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                        (Text -> Either Text Integer
forall a b. a -> Either a b
Left (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" states no quantity of the token at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r))
                        Integer -> Either Text Integer
forall a b. b -> Either a b
Right
        (holders, holderFaults) = case provider of
            Text
"koios" ->
                Text
-> Text
-> (Value -> Bool)
-> Maybe Value
-> (Maybe [(Text, Integer)], [Text])
census
                    Text
"the koios answer"
                    Text
"asset_list"
                    ( \Value
a ->
                        Value -> [Text] -> Maybe Text
str Value
a [Text
"policy_id"] Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
policy
                            Bool -> Bool -> Bool
&& Value -> [Text] -> Maybe Text
str Value
a [Text
"asset_name"] Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
                    )
                    ((Text -> Bool) -> Maybe Value
lastAnswer (Text
"/asset_utxos" Text -> Text -> Bool
`T.isSuffixOf`))
            Text
_ ->
                Text
-> Text
-> (Value -> Bool)
-> Maybe Value
-> (Maybe [(Text, Integer)], [Text])
census
                    Text
"the blockfrost answer"
                    Text
"amount"
                    (\Value
a -> Value -> [Text] -> Maybe Text
str Value
a [Text
"unit"] Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
unit)
                    ((Text -> Bool) -> Maybe Value
lastAnswer ((Text
"/utxos/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unit) Text -> Text -> Bool
`T.isSuffixOf`))
        answerDatum = case Text
provider of
            Text
"koios" -> do
                Aeson.Array os <- (Text -> Bool) -> Maybe Value
lastAnswer (Text
"/asset_utxos" Text -> Text -> Bool
`T.isSuffixOf`)
                case V.toList os of
                    [Value
o] -> Value -> [Text] -> Maybe Text
str Value
o [Text
"inline_datum", Text
"bytes"]
                    [Value]
_ -> Maybe Text
forall a. Maybe a
Nothing
            Text
_ -> do
                Aeson.Array os <- (Text -> Bool) -> Maybe Value
lastAnswer ((Text
"/utxos/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unit) Text -> Text -> Bool
`T.isSuffixOf`)
                case V.toList os of
                    [Value
o] -> Value -> [Text] -> Maybe Text
str Value
o [Text
"inline_datum"]
                    [Value]
_ -> Maybe Text
forall a. Maybe a
Nothing
        answerTip = case Text
provider of
            Text
"koios" -> case (Text -> Bool) -> Maybe Value
lastAnswer (Text
"/tip" Text -> Text -> Bool
`T.isSuffixOf`) of
                Just (Aeson.Array Array
ts)
                    | Just Value
t <- Array
ts Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
V.!? Int
0 ->
                        Text -> Whole -> Maybe Value -> Either Text (Maybe Integer)
whole Text
"the koios answer's tip slot" Whole
Count (Value -> [Text] -> Maybe Value
path Value
t [Text
"abs_slot"])
                Maybe Value
_ -> Maybe Integer -> Either Text (Maybe Integer)
forall a b. b -> Either a b
Right Maybe Integer
forall a. Maybe a
Nothing
            Text
_ -> case (Text -> Bool) -> Maybe Value
lastAnswer (Text
"/blocks/latest" Text -> Text -> Bool
`T.isSuffixOf`) of
                Just Value
b -> Text -> Whole -> Maybe Value -> Either Text (Maybe Integer)
whole Text
"the blockfrost answer's tip slot" Whole
Count (Value -> [Text] -> Maybe Value
path Value
b [Text
"slot"])
                Maybe Value
Nothing -> Maybe Integer -> Either Text (Maybe Integer)
forall a b. b -> Either a b
Right Maybe Integer
forall a. Maybe a
Nothing
        tipSlot =
            Text -> Whole -> Maybe Value -> Either Text (Maybe Integer)
whole
                Text
"the record's indexer tip slot"
                Whole
Count
                (Value -> [Text] -> Maybe Value
path Value
v [Text
"indexer", Text
"tipSlot"])
        maxLag = Text -> Whole -> Maybe Value -> Either Text (Maybe Integer)
whole Text
"the record's maximum lag" Whole
Count (Value -> [Text] -> Maybe Value
path Value
v [Text
"maxLagSlots"])
        lagSlots = Text -> Whole -> Maybe Value -> Either Text (Maybe Integer)
whole Text
"the record's stated lag" Whole
Lag (Value -> [Text] -> Maybe Value
path Value
v [Text
"lagSlots"])
        exact = Maybe a -> Either a (Maybe a) -> Maybe a
forall b a. b -> Either a b -> b
fromRight Maybe a
forall a. Maybe a
Nothing
        addresses = case Text
provider of
            Text
"koios" -> Maybe Int
forall a. Maybe a
Nothing
            Text
_ -> case (Text -> Bool) -> Maybe Value
lastAnswer ((Text
"/assets/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/addresses") Text -> Text -> Bool
`T.isSuffixOf`) of
                Just (Aeson.Array Array
as) -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Array -> Int
forall a. Vector a -> Int
V.length Array
as)
                Maybe Value
_ -> Maybe Int
forall a. Maybe a
Nothing
    pure
        IndexerRead
            { irProvider = provider
            , irPolicy = policy
            , irAssetName = name
            , irHolders = holders
            , irHolderAddresses = addresses
            , irAnswerDatum = answerDatum
            , irAnswerTip = exact answerTip
            , irIndexerOutput = found
            , irIndexerDatumCbor = cbor
            , irIndexerDatumHashRecorded = recomputed
            , irIndexerDatumHashComputed = Nothing
            , irIndexerTipSlot = exact tipSlot
            , irMaxLagSlots = exact maxLag
            , irNodeOutput = nodeOut
            , irNodeDatumCbor = nodeCbor
            , irNodeDatumHash = nodeHash
            , irNodeChainPoint = point
            , irStated =
                Stated
                    { stHolds = holds
                    , stSameOutput = sameOut
                    , stSameDatumBytes = bytes
                    , stSameDatumHash = hash
                    , stWithinLag = lagOk
                    , stLagSlots = exact lagSlots
                    }
            , irMalformed =
                holderFaults <> lefts [answerTip, tipSlot, maxLag, lagSlots]
            }
  where
    path :: Aeson.Value -> [Text] -> Maybe Aeson.Value
    path :: Value -> [Text] -> Maybe Value
path = Maybe Value -> [Text] -> Maybe Value
go (Maybe Value -> [Text] -> Maybe Value)
-> (Value -> Maybe Value) -> Value -> [Text] -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just
      where
        go :: Maybe Value -> [Text] -> Maybe Value
go Maybe Value
cur [] = Maybe Value
cur
        go (Just (Aeson.Object Object
o)) (Text
k : [Text]
ks) = Maybe Value -> [Text] -> Maybe Value
go (Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
k) Object
o) [Text]
ks
        go Maybe Value
_ [Text]
_ = Maybe Value
forall a. Maybe a
Nothing
    str :: Value -> [Text] -> Maybe Text
str Value
o [Text]
p = case Value -> [Text] -> Maybe Value
path Value
o [Text]
p of
        Just (Aeson.String Text
s) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
        Maybe Value
_ -> Maybe Text
forall a. Maybe a
Nothing
    bool :: [Text] -> Maybe Bool
bool [Text]
p = case Value -> [Text] -> Maybe Value
path Value
v [Text]
p of
        Just (Aeson.Bool Bool
b) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b
        Maybe Value
_ -> Maybe Bool
forall a. Maybe a
Nothing
    {- A whole-number fact the record may keep, as text ("135000000") or as a
    number: absent (no value, null, or the empty text the script writes for a
    tip it did not read), exact, or malformed and named with its raw value. -}
    whole
        :: Text -> Whole -> Maybe Aeson.Value -> Either Text (Maybe Integer)
    whole :: Text -> Whole -> Maybe Value -> Either Text (Maybe Integer)
whole Text
what Whole
d Maybe Value
raw = case Maybe Value
raw of
        Maybe Value
Nothing -> Maybe Integer -> Either Text (Maybe Integer)
forall a b. b -> Either a b
Right Maybe Integer
forall a. Maybe a
Nothing
        Just Value
Aeson.Null -> Maybe Integer -> Either Text (Maybe Integer)
forall a b. b -> Either a b
Right Maybe Integer
forall a. Maybe a
Nothing
        Just (Aeson.String Text
"") -> Maybe Integer -> Either Text (Maybe Integer)
forall a b. b -> Either a b
Right Maybe Integer
forall a. Maybe a
Nothing
        Just Value
x -> Either Text (Maybe Integer)
-> (Integer -> Either Text (Maybe Integer))
-> Maybe Integer
-> Either Text (Maybe Integer)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text (Maybe Integer)
forall a b. a -> Either a b
Left (Text -> Whole -> Value -> Text
notWhole Text
what Whole
d Value
x)) (Maybe Integer -> Either Text (Maybe Integer)
forall a b. b -> Either a b
Right (Maybe Integer -> Either Text (Maybe Integer))
-> (Integer -> Maybe Integer)
-> Integer
-> Either Text (Maybe Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Maybe Integer
forall a. a -> Maybe a
Just) (Whole -> Value -> Maybe Integer
wholeIn Whole
d Value
x)

instance ToJSON Account where
    toJSON :: Account -> Value
toJSON Account
a =
        [Pair] -> Value
object
            [ Key
"fee" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Account -> Integer
acFee Account
a
            , Key
"collateralInputs" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Account -> [Text]
acCollateralInputs Account
a
            , Key
"collateralTotal" Key -> Maybe Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Account -> Maybe Integer
acCollateralTotal Account
a
            , Key
"collateralReturn" Key -> Maybe Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Account -> Maybe Integer
acCollateralReturn Account
a
            , Key
"spends" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Account -> [Text]
acSpends Account
a
            ]

data Observation = Observation
    { Observation -> Text
obRoot :: Text
    -- ^ The root the registry's state output commits to
    , Observation -> Maybe Text
obHolding :: Maybe Text
    -- ^ The key's one live holding at the application, if any
    , Observation -> Maybe Integer
obHoldingLovelace :: Maybe Integer
    , Observation -> [Text]
obPending :: [Text]
    -- ^ The requests pending at the registry's request address
    , Observation -> Integer
obPendingLovelace :: Integer
    , Observation -> Integer
obWalletLovelace :: Integer
    , Observation -> Maybe Text
obLeaf :: Maybe Text
    {- ^ The key's leaf, authenticated by public replay at the root the
    chain holds: @active@, @terminal@ or @absent@; nothing when the
    acquired history does not prove it
    -}
    }
    deriving stock (Observation -> Observation -> Bool
(Observation -> Observation -> Bool)
-> (Observation -> Observation -> Bool) -> Eq Observation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Observation -> Observation -> Bool
== :: Observation -> Observation -> Bool
$c/= :: Observation -> Observation -> Bool
/= :: Observation -> Observation -> Bool
Eq, Int -> Observation -> ShowS
[Observation] -> ShowS
Observation -> [Char]
(Int -> Observation -> ShowS)
-> (Observation -> [Char])
-> ([Observation] -> ShowS)
-> Show Observation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Observation -> ShowS
showsPrec :: Int -> Observation -> ShowS
$cshow :: Observation -> [Char]
show :: Observation -> [Char]
$cshowList :: [Observation] -> ShowS
showList :: [Observation] -> ShowS
Show)

instance ToJSON Observation where
    toJSON :: Observation -> Value
toJSON Observation
o =
        [Pair] -> Value
object
            [ Key
"root" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Observation -> Text
obRoot Observation
o
            , Key
"holding" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Observation -> Maybe Text
obHolding Observation
o
            , Key
"holdingLovelace" Key -> Maybe Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Observation -> Maybe Integer
obHoldingLovelace Observation
o
            , Key
"pending" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Observation -> [Text]
obPending Observation
o
            , Key
"pendingLovelace" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Observation -> Integer
obPendingLovelace Observation
o
            , Key
"walletLovelace" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Observation -> Integer
obWalletLovelace Observation
o
            , Key
"leaf" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Observation -> Maybe Text
obLeaf Observation
o
            ]

instance FromJSON Observation where
    parseJSON :: Value -> Parser Observation
parseJSON = [Char]
-> (Object -> Parser Observation) -> Value -> Parser Observation
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"observation" ((Object -> Parser Observation) -> Value -> Parser Observation)
-> (Object -> Parser Observation) -> Value -> Parser Observation
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text
-> Maybe Text
-> Maybe Integer
-> [Text]
-> Integer
-> Integer
-> Maybe Text
-> Observation
Observation
            (Text
 -> Maybe Text
 -> Maybe Integer
 -> [Text]
 -> Integer
 -> Integer
 -> Maybe Text
 -> Observation)
-> Parser Text
-> Parser
     (Maybe Text
      -> Maybe Integer
      -> [Text]
      -> Integer
      -> Integer
      -> Maybe Text
      -> Observation)
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
"root"
            Parser
  (Maybe Text
   -> Maybe Integer
   -> [Text]
   -> Integer
   -> Integer
   -> Maybe Text
   -> Observation)
-> Parser (Maybe Text)
-> Parser
     (Maybe Integer
      -> [Text] -> Integer -> Integer -> Maybe Text -> Observation)
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
"holding"
            Parser
  (Maybe Integer
   -> [Text] -> Integer -> Integer -> Maybe Text -> Observation)
-> Parser (Maybe Integer)
-> Parser
     ([Text] -> Integer -> Integer -> Maybe Text -> Observation)
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
"holdingLovelace"
            Parser ([Text] -> Integer -> Integer -> Maybe Text -> Observation)
-> Parser [Text]
-> Parser (Integer -> Integer -> Maybe Text -> Observation)
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
"pending"
            Parser (Integer -> Integer -> Maybe Text -> Observation)
-> Parser Integer -> Parser (Integer -> Maybe Text -> Observation)
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
"pendingLovelace"
            Parser (Integer -> Maybe Text -> Observation)
-> Parser Integer -> Parser (Maybe Text -> Observation)
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
"walletLovelace"
            Parser (Maybe Text -> Observation)
-> Parser (Maybe Text) -> Parser Observation
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
"leaf"

{- | What one action left. The step number, action, target and key say
which action it answers; a receipt answering another is not accepted.
-}
data Receipt = Receipt
    { Receipt -> Int
rcStep :: Int
    , Receipt -> Text
rcAction :: Text
    , Receipt -> Text
rcTarget :: Text
    , Receipt -> Text
rcKey :: Text
    , Receipt -> Text
rcOutcome :: Text
    {- ^ A command's own outcome class; @accepted@, @ledger-refused@,
    @client-error@, @submit-unknown@ or @unconfirmed@ for a booking or a
    fold; @observed@ for a readback
    -}
    , Receipt -> Maybe Text
rcTxId :: Maybe Text
    , Receipt -> Maybe Text
rcPendingRequest :: Maybe Text
    -- ^ The request a stopped command names as left pending
    , Receipt -> Maybe Text
rcEvaluation :: Maybe Text
    -- ^ @skipped@ for a fold submitted without local evaluation
    , Receipt -> Maybe Text
rcStateValidator :: Maybe Text
    -- ^ The registry's state validator hash, from its pins
    , Receipt -> Maybe Text
rcApplication :: Maybe Text
    -- ^ The applied open-datum script's hash, from its pins
    , Receipt -> [Text]
rcRefusingScripts :: [Text]
    -- ^ The script hashes the node's refusal names
    , Receipt -> [Text]
rcPhaseWords :: [Text]
    {- ^ The node's words for a script that executed and failed, as they
    occur in its rejection: @PlutusFailure@, @CekError@; none for a
    rejection before any script ran
    -}
    , Receipt -> Maybe Text
rcRejectionFile :: Maybe Text
    -- ^ The node's full rejection text, kept beside the receipt
    , Receipt -> Maybe Text
rcRejectionSha256 :: Maybe Text
    , Receipt -> Maybe Text
rcBodyFile :: Maybe Text
    -- ^ The submitted transaction's body, kept beside the receipt
    , Receipt -> Maybe Text
rcBodySha256 :: Maybe Text
    , Receipt -> [Submission]
rcSubmissions :: [Submission]
    {- ^ For an ordinary command: every submission its registry's journal
    recorded while it ran, with the body the command kept
    -}
    , Receipt -> [Resolved]
rcResolved :: [Resolved]
    {- ^ For an ordinary command: every live output its journal read back
    without submitting it (a reference an earlier command published)
    -}
    , Receipt -> Maybe JournalSpan
rcJournal :: Maybe JournalSpan
    {- ^ For an ordinary command: the lines its registry's journal gained
    while it ran, bound by digest
    -}
    , Receipt -> Maybe ProcessEvidence
rcProcess :: Maybe ProcessEvidence
    -- ^ For a provoked command: what its process left, as recorded
    , Receipt -> Maybe [Text]
rcAdmission :: Maybe [Text]
    {- ^ What reading the retained body and rejection back found wrong;
    nothing until the receipt is admitted. Never read from a receipt file:
    only admission sets it.
    -}
    , Receipt -> Maybe Text
rcReason :: Maybe Text
    -- ^ The node's or the command's own words, bounded
    , Receipt -> Maybe Observation
rcObservation :: Maybe Observation
    , Receipt -> Maybe Integer
rcAllowance :: Maybe Integer
    {- ^ The most collateral a node-judged transaction of this run may state;
    none when the run set no bound
    -}
    , Receipt -> Maybe Account
rcAccount :: Maybe Account
    {- ^ Its fee and collateral, read back from the retained body by
    admission; nothing until the receipt is admitted
    -}
    , Receipt -> Maybe Text
rcReadbackFile :: Maybe Text
    -- ^ For an indexer read: the readback record kept beside the receipt
    , Receipt -> Maybe Text
rcReadbackSha256 :: Maybe Text
    , Receipt -> Maybe IndexerRead
rcIndexer :: Maybe IndexerRead
    , Receipt -> Maybe Integer
rcMaxLag :: Maybe Integer
    -- ^ For an indexer read: the maximum lag in slots the take was configured with
    , -- \^ What the retained readback record says, read back from its bytes by
      --    admission; nothing until the receipt is admitted
      --
      Receipt -> [Text]
rcEvidence :: [Text]
    -- ^ Files beside the receipt: command output, transaction bodies
    , Receipt -> Maybe Value
rcCommand :: Maybe Aeson.Value
    -- ^ A command's own printed receipt, as it printed it
    , Receipt -> Maybe Int
rcWithheldReads :: Maybe Int
    {- ^ For an @inspect@ run with the public history it needs withheld:
    how many of the targeted registry's history reads the forwarder in
    front of its provider answered empty
    -}
    }
    deriving stock (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, Int -> Receipt -> ShowS
[Receipt] -> ShowS
Receipt -> [Char]
(Int -> Receipt -> ShowS)
-> (Receipt -> [Char]) -> ([Receipt] -> ShowS) -> Show Receipt
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Receipt -> ShowS
showsPrec :: Int -> Receipt -> ShowS
$cshow :: Receipt -> [Char]
show :: Receipt -> [Char]
$cshowList :: [Receipt] -> ShowS
showList :: [Receipt] -> ShowS
Show)

emptyReceipt :: Int -> Text -> Text -> Text -> Receipt
emptyReceipt :: Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
step Text
act Text
target Text
key =
    Receipt
        { rcStep :: Int
rcStep = Int
step
        , rcAction :: Text
rcAction = Text
act
        , rcTarget :: Text
rcTarget = Text
target
        , rcKey :: Text
rcKey = Text
key
        , rcOutcome :: Text
rcOutcome = Text
""
        , rcTxId :: Maybe Text
rcTxId = Maybe Text
forall a. Maybe a
Nothing
        , rcPendingRequest :: Maybe Text
rcPendingRequest = Maybe Text
forall a. Maybe a
Nothing
        , rcEvaluation :: Maybe Text
rcEvaluation = Maybe Text
forall a. Maybe a
Nothing
        , rcStateValidator :: Maybe Text
rcStateValidator = Maybe Text
forall a. Maybe a
Nothing
        , rcApplication :: Maybe Text
rcApplication = Maybe Text
forall a. Maybe a
Nothing
        , rcRefusingScripts :: [Text]
rcRefusingScripts = []
        , rcPhaseWords :: [Text]
rcPhaseWords = []
        , rcRejectionFile :: Maybe Text
rcRejectionFile = Maybe Text
forall a. Maybe a
Nothing
        , rcRejectionSha256 :: Maybe Text
rcRejectionSha256 = Maybe Text
forall a. Maybe a
Nothing
        , rcBodyFile :: Maybe Text
rcBodyFile = Maybe Text
forall a. Maybe a
Nothing
        , rcBodySha256 :: Maybe Text
rcBodySha256 = Maybe Text
forall a. Maybe a
Nothing
        , rcSubmissions :: [Submission]
rcSubmissions = []
        , rcResolved :: [Resolved]
rcResolved = []
        , rcJournal :: Maybe JournalSpan
rcJournal = Maybe JournalSpan
forall a. Maybe a
Nothing
        , rcProcess :: Maybe ProcessEvidence
rcProcess = Maybe ProcessEvidence
forall a. Maybe a
Nothing
        , rcAdmission :: Maybe [Text]
rcAdmission = Maybe [Text]
forall a. Maybe a
Nothing
        , rcReason :: Maybe Text
rcReason = Maybe Text
forall a. Maybe a
Nothing
        , rcObservation :: Maybe Observation
rcObservation = Maybe Observation
forall a. Maybe a
Nothing
        , rcAllowance :: Maybe Integer
rcAllowance = Maybe Integer
forall a. Maybe a
Nothing
        , rcAccount :: Maybe Account
rcAccount = Maybe Account
forall a. Maybe a
Nothing
        , rcReadbackFile :: Maybe Text
rcReadbackFile = Maybe Text
forall a. Maybe a
Nothing
        , rcReadbackSha256 :: Maybe Text
rcReadbackSha256 = Maybe Text
forall a. Maybe a
Nothing
        , rcIndexer :: Maybe IndexerRead
rcIndexer = Maybe IndexerRead
forall a. Maybe a
Nothing
        , rcMaxLag :: Maybe Integer
rcMaxLag = Maybe Integer
forall a. Maybe a
Nothing
        , rcEvidence :: [Text]
rcEvidence = []
        , rcCommand :: Maybe Value
rcCommand = Maybe Value
forall a. Maybe a
Nothing
        , rcWithheldReads :: Maybe Int
rcWithheldReads = Maybe Int
forall a. Maybe a
Nothing
        }

instance ToJSON Receipt where
    toJSON :: Receipt -> Value
toJSON Receipt
r =
        [Pair] -> Value
object
            [ Key
"step" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Int
rcStep Receipt
r
            , Key
"action" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Text
rcAction Receipt
r
            , Key
"target" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Text
rcTarget Receipt
r
            , Key
"key" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Text
rcKey Receipt
r
            , Key
"outcome" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Text
rcOutcome Receipt
r
            , Key
"txId" 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
rcTxId Receipt
r
            , Key
"pendingRequest" 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
rcPendingRequest Receipt
r
            , Key
"evaluation" 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
rcEvaluation Receipt
r
            , Key
"stateValidator" 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
rcStateValidator Receipt
r
            , Key
"application" 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
rcApplication Receipt
r
            , Key
"refusingScripts" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> [Text]
rcRefusingScripts Receipt
r
            , Key
"phaseWords" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> [Text]
rcPhaseWords Receipt
r
            , Key
"rejectionFile" 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
rcRejectionFile Receipt
r
            , Key
"rejectionSha256" 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
rcRejectionSha256 Receipt
r
            , Key
"bodyFile" 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
rcBodyFile Receipt
r
            , Key
"bodySha256" 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
rcBodySha256 Receipt
r
            , Key
"submissions" Key -> [Submission] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> [Submission]
rcSubmissions Receipt
r
            , Key
"resolved" Key -> [Resolved] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> [Resolved]
rcResolved Receipt
r
            , Key
"journal" Key -> Maybe JournalSpan -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe JournalSpan
rcJournal Receipt
r
            , Key
"process" Key -> Maybe ProcessEvidence -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe ProcessEvidence
rcProcess Receipt
r
            , Key
"reason" 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
rcReason Receipt
r
            , Key
"observation" Key -> Maybe Observation -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe Observation
rcObservation Receipt
r
            , Key
"allowance" 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
rcAllowance Receipt
r
            , Key
"readbackFile" 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
rcReadbackFile Receipt
r
            , Key
"readbackSha256" 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
rcReadbackSha256 Receipt
r
            , Key
"maxLag" 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
rcMaxLag Receipt
r
            , Key
"evidence" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> [Text]
rcEvidence Receipt
r
            , Key
"command" 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
rcCommand Receipt
r
            , Key
"withheldReads" Key -> Maybe Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Receipt -> Maybe Int
rcWithheldReads Receipt
r
            ]

instance FromJSON Receipt where
    parseJSON :: Value -> Parser Receipt
parseJSON = [Char] -> (Object -> Parser Receipt) -> Value -> Parser Receipt
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"receipt" ((Object -> Parser Receipt) -> Value -> Parser Receipt)
-> (Object -> Parser Receipt) -> Value -> Parser Receipt
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Int
-> Text
-> Text
-> Text
-> Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [Text]
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> [Submission]
-> [Resolved]
-> Maybe JournalSpan
-> Maybe ProcessEvidence
-> Maybe [Text]
-> Maybe Text
-> Maybe Observation
-> Maybe Integer
-> Maybe Account
-> Maybe Text
-> Maybe Text
-> Maybe IndexerRead
-> Maybe Integer
-> [Text]
-> Maybe Value
-> Maybe Int
-> Receipt
Receipt
            (Int
 -> Text
 -> Text
 -> Text
 -> Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> [Text]
 -> [Text]
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> [Submission]
 -> [Resolved]
 -> Maybe JournalSpan
 -> Maybe ProcessEvidence
 -> Maybe [Text]
 -> Maybe Text
 -> Maybe Observation
 -> Maybe Integer
 -> Maybe Account
 -> Maybe Text
 -> Maybe Text
 -> Maybe IndexerRead
 -> Maybe Integer
 -> [Text]
 -> Maybe Value
 -> Maybe Int
 -> Receipt)
-> Parser Int
-> Parser
     (Text
      -> Text
      -> Text
      -> Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> Receipt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"step"
            Parser
  (Text
   -> Text
   -> Text
   -> Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser Text
-> Parser
     (Text
      -> Text
      -> Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"action"
            Parser
  (Text
   -> Text
   -> Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser Text
-> Parser
     (Text
      -> Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"target"
            Parser
  (Text
   -> Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser Text
-> Parser
     (Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"key"
            Parser
  (Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser Text
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"outcome"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"txId"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"pendingRequest"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> [Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"evaluation"
            Parser
  (Maybe Text
   -> Maybe Text
   -> [Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> [Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"stateValidator"
            Parser
  (Maybe Text
   -> [Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     ([Text]
      -> [Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"application"
            Parser
  ([Text]
   -> [Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser [Text]
-> Parser
     ([Text]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"refusingScripts"
            Parser
  ([Text]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser [Text]
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Parser (Maybe [Text]) -> Parser [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"phaseWords")
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"rejectionFile"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"rejectionSha256"
            Parser
  (Maybe Text
   -> Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> [Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"bodyFile"
            Parser
  (Maybe Text
   -> [Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     ([Submission]
      -> [Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"bodySha256"
            Parser
  ([Submission]
   -> [Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser [Submission]
-> Parser
     ([Resolved]
      -> Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Submission] -> Maybe [Submission] -> [Submission]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Submission] -> [Submission])
-> Parser (Maybe [Submission]) -> Parser [Submission]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe [Submission])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"submissions")
            Parser
  ([Resolved]
   -> Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser [Resolved]
-> Parser
     (Maybe JournalSpan
      -> Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Resolved] -> Maybe [Resolved] -> [Resolved]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Resolved] -> [Resolved])
-> Parser (Maybe [Resolved]) -> Parser [Resolved]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe [Resolved])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"resolved")
            Parser
  (Maybe JournalSpan
   -> Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe JournalSpan)
-> Parser
     (Maybe ProcessEvidence
      -> Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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 JournalSpan)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"journal"
            Parser
  (Maybe ProcessEvidence
   -> Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe ProcessEvidence)
-> Parser
     (Maybe [Text]
      -> Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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 ProcessEvidence)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"process"
            Parser
  (Maybe [Text]
   -> Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe [Text])
-> Parser
     (Maybe Text
      -> Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [Text] -> Parser (Maybe [Text])
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Text]
forall a. Maybe a
Nothing
            Parser
  (Maybe Text
   -> Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe Observation
      -> Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"reason"
            Parser
  (Maybe Observation
   -> Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Observation)
-> Parser
     (Maybe Integer
      -> Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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 Observation)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"observation"
            Parser
  (Maybe Integer
   -> Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Integer)
-> Parser
     (Maybe Account
      -> Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"allowance"
            Parser
  (Maybe Account
   -> Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Account)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Account -> Parser (Maybe Account)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Account
forall a. Maybe a
Nothing
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe IndexerRead
      -> Maybe Integer
      -> [Text]
      -> Maybe Value
      -> Maybe Int
      -> 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
"readbackFile"
            Parser
  (Maybe Text
   -> Maybe IndexerRead
   -> Maybe Integer
   -> [Text]
   -> Maybe Value
   -> Maybe Int
   -> Receipt)
-> Parser (Maybe Text)
-> Parser
     (Maybe IndexerRead
      -> Maybe Integer -> [Text] -> Maybe Value -> Maybe Int -> 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
"readbackSha256"
            Parser
  (Maybe IndexerRead
   -> Maybe Integer -> [Text] -> Maybe Value -> Maybe Int -> Receipt)
-> Parser (Maybe IndexerRead)
-> Parser
     (Maybe Integer -> [Text] -> Maybe Value -> Maybe Int -> Receipt)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe IndexerRead -> Parser (Maybe IndexerRead)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IndexerRead
forall a. Maybe a
Nothing
            Parser
  (Maybe Integer -> [Text] -> Maybe Value -> Maybe Int -> Receipt)
-> Parser (Maybe Integer)
-> Parser ([Text] -> Maybe Value -> Maybe Int -> 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
"maxLag"
            Parser ([Text] -> Maybe Value -> Maybe Int -> Receipt)
-> Parser [Text] -> Parser (Maybe Value -> Maybe Int -> 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
"evidence"
            Parser (Maybe Value -> Maybe Int -> Receipt)
-> Parser (Maybe Value) -> Parser (Maybe Int -> 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
"command"
            Parser (Maybe Int -> Receipt)
-> Parser (Maybe Int) -> 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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"withheldReads"

-- | The action name, target and key a receipt for this action must carry.
identify :: CliI res -> Maybe (Text, Text, Text)
identify :: forall res. CliI res -> Maybe (Text, Text, Text)
identify CliI res
i = case CliI res
i of
    Run Command
c (Target [Char]
t) [Char]
k -> (Text, Text, Text) -> Maybe (Text, Text, Text)
forall a. a -> Maybe a
Just (Text
"run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Command -> [Char]
commandName Command
c), [Char] -> Text
T.pack [Char]
t, [Char] -> Text
T.pack [Char]
k)
    RunByToken (Target [Char]
actor) Target
_ Command
c [Char]
k ->
        (Text, Text, Text) -> Maybe (Text, Text, Text)
forall a. a -> Maybe a
Just
            ( Text
"run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Command -> [Char]
commandName Command
c) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" by token"
            , [Char] -> Text
T.pack [Char]
actor
            , [Char] -> Text
T.pack [Char]
k
            )
    Book (Target [Char]
t) [Char]
k -> (Text, Text, Text) -> Maybe (Text, Text, Text)
forall a. a -> Maybe a
Just (Text
"book", [Char] -> Text
T.pack [Char]
t, [Char] -> Text
T.pack [Char]
k)
    FoldUnevaluated (Target [Char]
t) [Char]
k -> (Text, Text, Text) -> Maybe (Text, Text, Text)
forall a. a -> Maybe a
Just (Text
"fold-unevaluated", [Char] -> Text
T.pack [Char]
t, [Char] -> Text
T.pack [Char]
k)
    Observe (Target [Char]
t) [Char]
k -> (Text, Text, Text) -> Maybe (Text, Text, Text)
forall a. a -> Maybe a
Just (Text
"observe", [Char] -> Text
T.pack [Char]
t, [Char] -> Text
T.pack [Char]
k)
    Craft Crafted
c (Target [Char]
t) [Char]
k ->
        (Text, Text, Text) -> Maybe (Text, Text, Text)
forall a. a -> Maybe a
Just (Text
"craft " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Crafted -> [Char]
craftedName Crafted
c), [Char] -> Text
T.pack [Char]
t, [Char] -> Text
T.pack [Char]
k)
    Provoke Provocation
p (Target [Char]
t) [Char]
k ->
        (Text, Text, Text) -> Maybe (Text, Text, Text)
forall a. a -> Maybe a
Just (Text
"provoke " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Provocation -> [Char]
provocationName Provocation
p), [Char] -> Text
T.pack [Char]
t, [Char] -> Text
T.pack [Char]
k)
    Reclaim (Target [Char]
t) [Char]
k Receipt
_ Receipt
_ -> (Text, Text, Text) -> Maybe (Text, Text, Text)
forall a. a -> Maybe a
Just (Text
"reclaim", [Char] -> Text
T.pack [Char]
t, [Char] -> Text
T.pack [Char]
k)
    ReadIndexer Indexer
ix (Target [Char]
t) [Char]
k Receipt
_ ->
        (Text, Text, Text) -> Maybe (Text, Text, Text)
forall a. a -> Maybe a
Just (Text
"read-indexer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Indexer -> [Char]
indexerName Indexer
ix), [Char] -> Text
T.pack [Char]
t, [Char] -> Text
T.pack [Char]
k)
    Require Requirement
_ [Receipt]
_ -> Maybe (Text, Text, Text)
forall a. Maybe a
Nothing
    Retire [Char]
_ -> Maybe (Text, Text, Text)
forall a. Maybe a
Nothing

-- ---------------------------------------------------------
-- Checks
-- ---------------------------------------------------------

-- | A value inside a command's own receipt, by object keys and list indices.
at :: [Either Text Int] -> Receipt -> Maybe Aeson.Value
at :: [Either Text Int] -> Receipt -> Maybe Value
at [Either Text Int]
path Receipt
r = [Either Text Int] -> Value -> Maybe Value
go [Either Text Int]
path (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Receipt -> Maybe Value
rcCommand Receipt
r
  where
    go :: [Either Text Int] -> Value -> Maybe Value
go [] Value
v = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v
    go (Left Text
k : [Either Text Int]
rest) (Aeson.Object Object
o) = [Either Text Int] -> Value -> Maybe Value
go [Either Text Int]
rest (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
k) Object
o
    go (Right Int
i : [Either Text Int]
rest) (Aeson.Array Array
a) = [Either Text Int] -> Value -> Maybe Value
go [Either Text Int]
rest (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Array
a Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
V.!? Int
i)
    go [Either Text Int]
_ Value
_ = Maybe Value
forall a. Maybe a
Nothing

field :: Text -> Either Text Int
field :: Text -> Either Text Int
field = Text -> Either Text Int
forall a b. a -> Either a b
Left

-- | A settled request's own fact, from the receipt's settled list.
settledField :: Text -> Receipt -> Maybe Aeson.Value
settledField :: Text -> Receipt -> Maybe Value
settledField Text
name = [Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"settled", Int -> Either Text Int
forall a b. b -> Either a b
Right Int
0, Text -> Either Text Int
field Text
name]

-- | A settled request's settlement fact.
settlementField :: Text -> Receipt -> Maybe Aeson.Value
settlementField :: Text -> Receipt -> Maybe Value
settlementField Text
name =
    [Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"settled", Int -> Either Text Int
forall a b. b -> Either a b
Right Int
0, Text -> Either Text Int
field Text
"settlement", Text -> Either Text Int
field Text
name]

-- | The path of a settled settlement's envelope control fields.
settledControlPath :: [Either Text Int]
settledControlPath :: [Either Text Int]
settledControlPath =
    [ Text -> Either Text Int
field Text
"settled"
    , Int -> Either Text Int
forall a b. b -> Either a b
Right Int
0
    , Text -> Either Text Int
field Text
"settlement"
    , Text -> Either Text Int
field Text
"envelope"
    , Text -> Either Text Int
field Text
"fields"
    , Int -> Either Text Int
forall a b. b -> Either a b
Right Int
0
    , Text -> Either Text Int
field Text
"fields"
    ]

-- | Whether a receipt's settled list holds exactly the one pending request.
settledIsSingleton :: Receipt -> Bool
settledIsSingleton :: Receipt -> Bool
settledIsSingleton Receipt
r = case [Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"settled"] Receipt
r of
    Just (Aeson.Array Array
a) -> Array -> Int
forall a. Vector a -> Int
V.length Array
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    Maybe Value
_ -> Bool
False

-- | Fail unless a command receipt says @success@ and its submissions were admitted.
succeeded :: String -> Receipt -> [String]
succeeded :: [Char] -> Receipt -> [[Char]]
succeeded [Char]
what Receipt
r =
    [ [Char]
what [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"'s outcome is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not success"
    | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"success"
    ]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char]
what [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": ") [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) (Receipt -> [[Char]]
admitted Receipt
r)

-- | Fail unless the receipt's outcome is the one named.
outcomeIs :: Receipt -> Text -> [String]
outcomeIs :: Receipt -> Text -> [[Char]]
outcomeIs Receipt
r Text
expected =
    [ [Char]
"the outcome is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
expected
    | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
expected
    ]

{- | The booking verb a receipt's action names, without its actor suffix:
`run update by token` and `run update` both name `update`, which is what
the printed command's `verb` carries. A refusal run by token is still the
same booking verb, from another actor's directory.
-}
bookingVerb :: Text -> Text
bookingVerb :: Text -> Text
bookingVerb Text
act = case Text -> Text -> Maybe Text
T.stripPrefix Text
"run " Text
act of
    Just Text
rest -> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
rest (Text -> Text -> Maybe Text
T.stripSuffix Text
" by token" Text
rest)
    Maybe Text
Nothing -> Text
""

{- | The client-policy phrase a booking refusal must name, for the verb
the command ran and the leaf the readback authenticates: what the key
is, as the ordinary commands print it before signing. Anything else is
a different refusal, or none the key's entry calls for. The reason must
be exactly that key's refusal in the product format: the requested key
in its accepted spelling, one space, the state phrase, one space and
"(client policy)". A substring occurrence cannot certify the identity
of a named key, so a longer key containing the requested spelling fails,
as does a printed command whose key is not that key (checked in 'check').
-}
bookingReason :: Text -> Text -> Text -> Observation -> [String]
bookingReason :: Text -> Text -> Text -> Observation -> [[Char]]
bookingReason Text
act Text
requestedKey Text
reason Observation
seen = case (Text
verb, Observation -> Maybe Text
obLeaf Observation
seen) of
    (Text
"insert", Just Text
"active") -> [Char] -> [[Char]]
want [Char]
"is already registered"
    (Text
"insert", Just Text
"terminal") -> [Char] -> [[Char]]
want [Char]
"is already retired"
    (Text
"update", Maybe Text
leaf)
        | Maybe Text
leaf Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"terminal" -> [Char] -> [[Char]]
want [Char]
"is already retired"
        | Maybe Text
leaf Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unknown" Bool -> Bool -> Bool
|| Maybe Text
leaf Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"absent" Bool -> Bool -> Bool
|| Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
leaf ->
            [Char] -> [[Char]]
want [Char]
"is not registered"
        | Bool
otherwise -> [[Char]]
unexpected
    (Text
"terminate", Maybe Text
leaf)
        | Maybe Text
leaf Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"terminal" -> [Char] -> [[Char]]
want [Char]
"is already retired"
        | Maybe Text
leaf Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unknown" Bool -> Bool -> Bool
|| Maybe Text
leaf Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"absent" Bool -> Bool -> Bool
|| Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
leaf ->
            [Char] -> [[Char]]
want [Char]
"is not registered"
        | Bool
otherwise -> [[Char]]
unexpected
    (Text, Maybe Text)
_ -> [[Char]]
unexpected
  where
    verb :: Text
verb = Text -> Text
bookingVerb Text
act
    want :: [Char] -> [[Char]]
want [Char]
phrase =
        [ [Char]
"the refusal does not name the key " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
phrase
        | Bool -> Bool
not ([Char] -> Text
T.pack [Char]
phrase Text -> Text -> Bool
`T.isInfixOf` Text
reason)
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the refusal is not labelled client policy"
               | Bool -> Bool
not (Text
"(client policy)" Text -> Text -> Bool
`T.isInfixOf` Text
reason)
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the refusal does not name the requested key \""
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
requestedKey
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\""
               | Text
reason Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char] -> Text
expectedRaw [Char]
phrase, [Char] -> Text
expectedHex [Char]
phrase]
               ]
      where
        expectedRaw :: [Char] -> Text
expectedRaw [Char]
p = Text
requestedKey Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (client policy)"
        expectedHex :: [Char] -> Text
expectedHex [Char]
p =
            [Char] -> Text
hexLabel (Text -> [Char]
T.unpack Text
requestedKey)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
p
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (client policy)"
    unexpected :: [[Char]]
unexpected =
        [ [Char]
"the "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
verb
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" of the "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Text -> [Char]) -> Maybe Text -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"unproven" Text -> [Char]
T.unpack (Observation -> Maybe Text
obLeaf Observation
seen)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" key is not ruled out by its entry"
        ]

-- | The outcome class a provoked command's condition calls for.
expectedOutcome :: Receipt -> Text
expectedOutcome :: Receipt -> Text
expectedOutcome Receipt
r = case Text -> Text -> Maybe Text
T.stripPrefix Text
"provoke " (Receipt -> Text
rcAction Receipt
r) of
    Just Text
"insert-while-locked" -> Text
"concurrent-writer"
    Just Text
"inspect-without-history" -> Text
"stale-state"
    Just Text
"inspect-without-node" -> Text
"node-unavailable"
    Just Text
"create-again" -> Text
"client-refusal"
    Maybe Text
_ -> Text
"a provoked command's outcome"

-- | The step a killed command was killed at, by the node's acceptance of it.
killedStep :: Receipt -> Text
killedStep :: Receipt -> Text
killedStep Receipt
r = case Text -> Text -> Maybe Text
T.stripPrefix Text
"provoke " (Receipt -> Text
rcAction Receipt
r) of
    Just Text
"terminate-killed" -> Text
"fold"
    Just Text
"create-killed" -> Text
"boot"
    Maybe Text
_ -> Text
"step"

-- | The checks on what a provoked command's process left, if it was recorded.
withProcess :: Receipt -> (ProcessEvidence -> [String]) -> [String]
withProcess :: Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess Receipt
r ProcessEvidence -> [[Char]]
f =
    [[Char]]
-> (ProcessEvidence -> [[Char]])
-> Maybe ProcessEvidence
-> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        [[Char]
"what the command's process left is not recorded"]
        ProcessEvidence -> [[Char]]
f
        (Receipt -> Maybe ProcessEvidence
rcProcess Receipt
r)

{- | A provoked @inspect@: its outcome is the class its condition names,
and it printed no leaf.
-}
noLeaf :: Receipt -> [String]
noLeaf :: Receipt -> [[Char]]
noLeaf Receipt
r =
    Receipt -> Text -> [[Char]]
outcomeIs Receipt
r (Receipt -> Text
expectedOutcome Receipt
r)
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"a leaf was printed: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Value -> [Char]) -> Maybe Value -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" Value -> [Char]
forall a. Show a => a -> [Char]
show Maybe Value
leaf
           | let leaf :: Maybe Value
leaf = [Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
r
           , Maybe Value
leaf 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
Aeson.Null]
           ]

{- | An @inspect@ run with the public history it needs withheld. The
forwarder in front of its provider must have withheld at least one of the
targeted registry's history reads; then the command ends stale-state,
prints no leaf and names @HistoryIncomplete@. A withholding that never
reached the history read is judged for that alone: what the command then
printed is its consequence, not a second finding. In every case the
registry's journal must not have moved.
-}
withheldHistory :: Receipt -> [String]
withheldHistory :: Receipt -> [[Char]]
withheldHistory Receipt
r =
    [[Char]]
reached [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess Receipt
r ProcessEvidence -> [[Char]]
journalStill
  where
    reached :: [[Char]]
reached = case Receipt -> Maybe Int
rcWithheldReads Receipt
r of
        Maybe Int
Nothing -> [[Char]
"no forwarder recorded withholding the command's history reads"]
        Just Int
n
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 -> [[Char]
neverReached]
            | Bool
otherwise ->
                Receipt -> [[Char]]
noLeaf Receipt
r
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the refusal does not name HistoryIncomplete: "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Text -> [Char]) -> Maybe Text -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"no reason" Text -> [Char]
T.unpack (Receipt -> Maybe Text
rcReason Receipt
r)
                       | Bool -> Bool
not (Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text
"HistoryIncomplete" Text -> Text -> Bool
`T.isInfixOf`) (Receipt -> Maybe Text
rcReason Receipt
r))
                       ]

-- | The one finding of a withholding that missed the command's history read.
neverReached :: String
neverReached :: [Char]
neverReached =
    [Char]
"the withholding never reached the command's history read: none of the registry's history reads was withheld"

-- | Fail unless the registry's journal did not move while the command ran.
journalStill :: ProcessEvidence -> [String]
journalStill :: ProcessEvidence -> [[Char]]
journalStill ProcessEvidence
p =
    [ [Char]
"the registry's journal moved from "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (ProcessEvidence -> Int
peJournalBefore ProcessEvidence
p)
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" to "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (ProcessEvidence -> Int
peJournalAfter ProcessEvidence
p)
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" lines"
    | ProcessEvidence -> Int
peJournalAfter ProcessEvidence
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= ProcessEvidence -> Int
peJournalBefore ProcessEvidence
p
    ]

-- | Fail unless the command submitted nothing.
nothingSubmitted :: Receipt -> ProcessEvidence -> [String]
nothingSubmitted :: Receipt -> ProcessEvidence -> [[Char]]
nothingSubmitted Receipt
r ProcessEvidence
p =
    [ [Char]
"the command submitted "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ProcessEvidence -> [Text]
peSubmitted ProcessEvidence
p))
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" transactions"
    | Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ProcessEvidence -> [Text]
peSubmitted ProcessEvidence
p)) Bool -> Bool -> Bool
|| Bool -> Bool
not ([Submission] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Receipt -> [Submission]
rcSubmissions Receipt
r))
    ]

{- | Fail unless the inspect observed, from the chain, the transaction the
killed command submitted (its first or last, as chosen).
-}
observedKilled :: Receipt -> Receipt -> ([Text] -> [Text]) -> [String]
observedKilled :: Receipt -> Receipt -> ([Text] -> [Text]) -> [[Char]]
observedKilled Receipt
killed Receipt
seen [Text] -> [Text]
pick =
    Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess Receipt
killed ((ProcessEvidence -> [[Char]]) -> [[Char]])
-> (ProcessEvidence -> [[Char]]) -> [[Char]]
forall a b. (a -> b) -> a -> b
$ \ProcessEvidence
p -> case [Text] -> [Text]
pick (ProcessEvidence -> [Text]
peSubmitted ProcessEvidence
p) of
        [] -> [[Char]
"the killed command's journal records no submission"]
        Text
t : [Text]
_ ->
            [ [Char]
"the inspect did not observe the killed command's transaction "
                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
t
            | Text -> Value
Aeson.String Text
t
                Value -> [Value] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Value] -> (Value -> [Value]) -> Maybe Value -> [Value]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Value -> [Value]
toList' ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"observed"] Receipt
seen)
            ]
  where
    toList' :: Value -> [Value]
toList' Value
v = case Value
v of
        Aeson.Array Array
a -> Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
a
        Value
_ -> []

-- | The strings of a receipt list value; anything else holds none.
strings :: Maybe Aeson.Value -> [Text]
strings :: Maybe Value -> [Text]
strings Maybe Value
v = case Maybe Value
v of
    Just (Aeson.Array Array
a) -> [Text
t | Aeson.String Text
t <- Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
a]
    Maybe Value
_ -> []

-- | Fail unless two receipt values are present and equal.
same :: String -> Maybe Aeson.Value -> Maybe Aeson.Value -> [String]
same :: [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same [Char]
what Maybe Value
a Maybe Value
b = case (Maybe Value
a, Maybe Value
b) of
    (Just Value
x, Just Value
y) | Value
x Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
y -> []
    (Maybe Value
Nothing, Maybe Value
_) -> [[Char]
what [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": the first receipt does not carry it"]
    (Maybe Value
_, Maybe Value
Nothing) -> [[Char]
what [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": the second receipt does not carry it"]
    (Maybe Value, Maybe Value)
_ -> [[Char]
what [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" differs"]

{- | An actor identity usable for comparison: present text, never an
absent or wrongly typed value a distinct-wallet claim could skip.
-}
usableIdentity :: Maybe Aeson.Value -> Maybe Text
usableIdentity :: Maybe Value -> Maybe Text
usableIdentity (Just (Aeson.String Text
t)) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
usableIdentity Maybe Value
_ = Maybe Text
forall a. Maybe a
Nothing

-- | Fail unless a receipt value is present and equals the one expected.
is :: String -> Aeson.Value -> Maybe Aeson.Value -> [String]
is :: [Char] -> Value -> Maybe Value -> [[Char]]
is [Char]
what Value
expected Maybe Value
v =
    [ [Char]
what [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Value -> [Char]) -> Maybe Value -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"absent" Value -> [Char]
plain Maybe Value
v [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> [Char]
plain Value
expected
    | Maybe Value
v Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value -> Maybe Value
forall a. a -> Maybe a
Just Value
expected
    ]
  where
    plain :: Value -> [Char]
plain Value
value = case Value
value of
        Aeson.String Text
t -> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
t
        Aeson.Array Array
a | Array -> Bool
forall a. Vector a -> Bool
V.null Array
a -> [Char]
"none"
        Value
other -> Value -> [Char]
forall a. Show a => a -> [Char]
show Value
other

{- | A node-judged transaction of a run that set a collateral bound states its
collateral, within the bound, and returns the rest of its funding output. The
statement is read from the body admission retained: a refusal that would have
put the whole funding output at risk does not pass.
-}
collateralBounded :: Receipt -> [String]
collateralBounded :: Receipt -> [[Char]]
collateralBounded Receipt
r = case Receipt -> Maybe Integer
rcAllowance Receipt
r of
    Maybe Integer
Nothing -> []
    Just Integer
allowance -> case Receipt -> Maybe Account
rcAccount Receipt
r of
        Maybe Account
Nothing -> [[Char]
"the collateral the transaction states is not recorded"]
        Just Account
a ->
            case Account -> Maybe Integer
acCollateralTotal Account
a of
                Maybe Integer
Nothing ->
                    [ [Char]
"the transaction states no total collateral, so the collateral it puts at risk is not bounded"
                    ]
                Just Integer
total ->
                    [ [Char]
"the transaction states a total collateral of "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
total
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", over the bound of "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
allowance
                    | Integer
total Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
allowance
                    ]
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the transaction returns no part of its collateral input"
                           | Maybe Integer -> Bool
forall a. Maybe a -> Bool
isNothing (Account -> Maybe Integer
acCollateralReturn Account
a)
                           ]

{- | One indexer's read of the Active key, against the fresh inspect that named
the key's token, recomputed from the facts the retained record keeps and never
from the summary it states: every whole number the record keeps (a quantity, an
output index, a slot, a lag) is exact in its domain, never a rounded fraction or
a malformed entry left out of a sum; the provider's own answer counts exactly one output
holding exactly one of the token under the policy and asset name the inspect
names, and that output is the one the record reports and the inspect's; the
indexer's datum bytes are the inspect's and their blake2b-256, computed at
admission, is the inspect's datum hash; the indexer's tip is no further behind
the inspect's separately observed tip than the maximum lag the take was configured with.
The inspect side of the record must be the inspect's own, and a stated summary its
facts contradict is itself a failure. What this cannot establish is that the
provider answered honestly: the record's digest proves the bytes judged are the
bytes kept, not where they came from.
-}
indexerAgrees :: Receipt -> Receipt -> [String]
indexerAgrees :: Receipt -> Receipt -> [[Char]]
indexerAgrees Receipt
inspect Receipt
r =
    Requirement -> [Receipt] -> [[Char]]
check Requirement
ReachedActive [Receipt
inspect]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the read's outcome is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not success"
           | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"success"
           ]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
-> (IndexerRead -> [[Char]]) -> Maybe IndexerRead -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            [[Char]
"the receipt's retained readback record was not read back"]
            IndexerRead -> [[Char]]
facts
            (Receipt -> Maybe IndexerRead
rcIndexer Receipt
r)
  where
    inspected :: [Either Text Int] -> Maybe Text
inspected [Either Text Int]
p = case [Either Text Int] -> Receipt -> Maybe Value
at [Either Text Int]
p Receipt
inspect of
        Just (Aeson.String Text
s) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
        Maybe Value
_ -> Maybe Text
forall a. Maybe a
Nothing
    inspectOutput :: Maybe Text
inspectOutput = [Either Text Int] -> Maybe Text
inspected [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"output"]
    inspectCbor :: Maybe Text
inspectCbor = [Either Text Int] -> Maybe Text
inspected [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"datumCbor"]
    inspectHash :: Maybe Text
inspectHash = [Either Text Int] -> Maybe Text
inspected [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"datumHash"]
    inspectPoint :: Maybe Text
inspectPoint = [Either Text Int] -> Maybe Text
inspected [Text -> Either Text Int
field Text
"observedTip"]
    nodeSlot :: Maybe Integer
    nodeSlot :: Maybe Integer
nodeSlot = Maybe Text
inspectPoint Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe Integer
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe Integer)
-> (Text -> [Char]) -> Text -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.')
    facts :: IndexerRead -> [[Char]]
facts IndexerRead
ir =
        [ [Char]
"the record is of "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (IndexerRead -> Text
irProvider IndexerRead
ir)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not of the indexer asked"
        | (Text
"read-indexer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IndexerRead -> Text
irProvider IndexerRead
ir) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Receipt -> Text
rcAction Receipt
r
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
                (([Char]
"the record keeps a malformed fact: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (Text -> [Char]) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack)
                (IndexerRead -> [Text]
irMalformed IndexerRead
ir)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"the token census: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [[Char]]
censusProblems
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the indexer's output "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (IndexerRead -> Text
irIndexerOutput IndexerRead
ir)
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not the node's"
               | Bool -> Bool
not Bool
outputOk
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the indexer's datum bytes are not the node's"
               | Bool -> Bool
not Bool
bytesOk
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the record reports datum bytes the provider's answer does not carry"
               | IndexerRead -> Maybe Text
irAnswerDatum IndexerRead
ir Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just (IndexerRead -> Text
irIndexerDatumCbor IndexerRead
ir)
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the record reports a tip of "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Integer -> [Char]) -> Maybe Integer -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none" Integer -> [Char]
forall a. Show a => a -> [Char]
show (IndexerRead -> Maybe Integer
irIndexerTipSlot IndexerRead
ir)
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", but the provider's answer says "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Integer -> [Char]) -> Maybe Integer -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none" Integer -> [Char]
forall a. Show a => a -> [Char]
show (IndexerRead -> Maybe Integer
irAnswerTip IndexerRead
ir)
               | IndexerRead -> Maybe Integer
irAnswerTip IndexerRead
ir Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= IndexerRead -> Maybe Integer
irIndexerTipSlot IndexerRead
ir
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
hashProblems
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
lagProblems
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the policy the indexer was asked about"
                (Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
Aeson.String (IndexerRead -> Text
irPolicy IndexerRead
ir)))
                ( [Either Text Int] -> Receipt -> Maybe Value
at
                    [ Text -> Either Text Int
field Text
"applicationOutput"
                    , Text -> Either Text Int
field Text
"envelope"
                    , Text -> Either Text Int
forall a b. a -> Either a b
Left Text
"fields"
                    , Int -> Either Text Int
forall a b. b -> Either a b
Right Int
0
                    , Text -> Either Text Int
forall a b. a -> Either a b
Left Text
"fields"
                    , Int -> Either Text Int
forall a b. b -> Either a b
Right Int
2
                    , Text -> Either Text Int
forall a b. a -> Either a b
Left Text
"bytes"
                    ]
                    Receipt
inspect
                )
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the asset name the indexer was asked about"
                (Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
Aeson.String (IndexerRead -> Text
irAssetName IndexerRead
ir)))
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"key"] Receipt
inspect)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the record's node " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
what [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not the inspect's"
               | ([Char]
what, Text
recorded, Maybe Text
fresh) <-
                    [ ([Char]
"output", IndexerRead -> Text
irNodeOutput IndexerRead
ir, Maybe Text
inspectOutput)
                    , ([Char]
"datum bytes", IndexerRead -> Text
irNodeDatumCbor IndexerRead
ir, Maybe Text
inspectCbor)
                    , ([Char]
"datum hash", IndexerRead -> Text
irNodeDatumHash IndexerRead
ir, Maybe Text
inspectHash)
                    , ([Char]
"chain point", IndexerRead -> Text
irNodeChainPoint IndexerRead
ir, Maybe Text
inspectPoint)
                    ]
               , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
recorded Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
fresh
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the record states "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
claim
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
stated
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", but its facts say "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
actual
               | ([Char]
claim, Bool
stated, Bool
actual) <-
                    [
                        ( [Char]
"holds"
                        , Stated -> Bool
stHolds Stated
st
                        , Bool
censusOk Bool -> Bool -> Bool
&& Bool
outputOk Bool -> Bool -> Bool
&& Bool
bytesOk Bool -> Bool -> Bool
&& Bool
hashOk Bool -> Bool -> Bool
&& Bool
lagOk Bool -> Bool -> Bool
&& Bool
rawOk
                        )
                    , ([Char]
"sameOutput", Stated -> Bool
stSameOutput Stated
st, Bool
outputOk)
                    , ([Char]
"sameDatumBytes", Stated -> Bool
stSameDatumBytes Stated
st, Bool
bytesOk)
                    , ([Char]
"sameDatumHash", Stated -> Bool
stSameDatumHash Stated
st, Bool
hashOk)
                    , ([Char]
"withinLag", Stated -> Bool
stWithinLag Stated
st, Bool
lagOk)
                    ]
               , Bool
stated Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
actual
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the record states a lag of "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Integer -> [Char]) -> Maybe Integer -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none" Integer -> [Char]
forall a. Show a => a -> [Char]
show (Stated -> Maybe Integer
stLagSlots Stated
st)
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" slots, but its tip and the inspect's chain point give "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Integer -> [Char]) -> Maybe Integer -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none" Integer -> [Char]
forall a. Show a => a -> [Char]
show Maybe Integer
lag
               | Stated -> Maybe Integer
stLagSlots Stated
st Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Integer
lag
               ]
      where
        st :: Stated
st = IndexerRead -> Stated
irStated IndexerRead
ir
        censusProblems :: [[Char]]
censusProblems = case IndexerRead -> Maybe [(Text, Integer)]
irHolders IndexerRead
ir of
            Maybe [(Text, Integer)]
Nothing -> [[Char]
"the record keeps no provider answer to count the holders from"]
            Just [(Text
ref, Integer
1)]
                | Text
ref Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= IndexerRead -> Text
irIndexerOutput IndexerRead
ir ->
                    [ [Char]
"the provider's answer names "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
ref
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not the output the record reports"
                    ]
                | Bool
otherwise -> [[Char]]
addressProblems
            Just [(Text
_, Integer
q)] ->
                [ [Char]
"the provider's answer holds "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
q
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" of the token in its one output; exactly one must"
                ]
            Just [(Text, Integer)]
hs ->
                [ [Char]
"the provider's answer counts "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([(Text, Integer)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Integer)]
hs)
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" outputs holding the token; exactly one must"
                ]
        addressProblems :: [[Char]]
addressProblems = case IndexerRead -> Maybe Int
irHolderAddresses IndexerRead
ir of
            Just Int
n
                | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 ->
                    [ [Char]
"the provider's answer counts "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" addresses holding the token; exactly one must"
                    ]
            Maybe Int
_ -> []
        censusOk :: Bool
censusOk = [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
censusProblems
        outputOk :: Bool
outputOk = Text -> Maybe Text
forall a. a -> Maybe a
Just (IndexerRead -> Text
irIndexerOutput IndexerRead
ir) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
inspectOutput
        bytesOk :: Bool
bytesOk =
            Bool -> Bool
not (Text -> Bool
T.null (IndexerRead -> Text
irIndexerDatumCbor IndexerRead
ir))
                Bool -> Bool -> Bool
&& Text -> Maybe Text
forall a. a -> Maybe a
Just (IndexerRead -> Text
irIndexerDatumCbor IndexerRead
ir) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
inspectCbor
        hashProblems :: [[Char]]
hashProblems = case IndexerRead -> Maybe Text
irIndexerDatumHashComputed IndexerRead
ir of
            Maybe Text
Nothing -> [[Char]
"admission computed no hash of the indexer's datum bytes"]
            Just Text
h ->
                [ [Char]
"the hash of the indexer's datum bytes is not the node's datum hash"
                | Text -> Maybe Text
forall a. a -> Maybe a
Just Text
h Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
inspectHash
                ]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the record's recomputed datum hash is not the hash of its own datum bytes"
                       | Text
h Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= IndexerRead -> Text
irIndexerDatumHashRecorded IndexerRead
ir
                       ]
        hashOk :: Bool
hashOk = case IndexerRead -> Maybe Text
irIndexerDatumHashComputed IndexerRead
ir of
            Just Text
h -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
h Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
inspectHash Bool -> Bool -> Bool
&& Text
h Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== IndexerRead -> Text
irIndexerDatumHashRecorded IndexerRead
ir
            Maybe Text
Nothing -> Bool
False
        lag :: Maybe Integer
lag = (-) (Integer -> Integer -> Integer)
-> Maybe Integer -> Maybe (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
nodeSlot Maybe (Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IndexerRead -> Maybe Integer
irIndexerTipSlot IndexerRead
ir
        lagProblems :: [[Char]]
lagProblems = case (Receipt -> Maybe Integer
rcMaxLag Receipt
r, Maybe Integer
lag) of
            (Maybe Integer
Nothing, Maybe Integer
_) -> [[Char]
"the read carries no maximum lag the take was configured with"]
            (Maybe Integer
_, Maybe Integer
Nothing) -> [[Char]
"the record keeps no indexer tip to measure the lag from"]
            (Just Integer
allowed, Just Integer
l) ->
                [ [Char]
"the record was run under a maximum lag of "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Integer -> [Char]) -> Maybe Integer -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none" Integer -> [Char]
forall a. Show a => a -> [Char]
show (IndexerRead -> Maybe Integer
irMaxLagSlots IndexerRead
ir)
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not the "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
allowed
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" the take configured"
                | IndexerRead -> Maybe Integer
irMaxLagSlots IndexerRead
ir Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
allowed
                ]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the indexer is "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
l
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" slots behind the node, beyond the "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
allowed
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" allowed"
                       | Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
allowed
                       ]
        rawOk :: Bool
rawOk =
            [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (IndexerRead -> [Text]
irMalformed IndexerRead
ir)
                Bool -> Bool -> Bool
&& IndexerRead -> Maybe Text
irAnswerDatum IndexerRead
ir Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (IndexerRead -> Text
irIndexerDatumCbor IndexerRead
ir)
                Bool -> Bool -> Bool
&& IndexerRead -> Maybe Integer
irAnswerTip IndexerRead
ir Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== IndexerRead -> Maybe Integer
irIndexerTipSlot IndexerRead
ir
        lagOk :: Bool
lagOk = case (Receipt -> Maybe Integer
rcMaxLag Receipt
r, Maybe Integer
lag) of
            (Just Integer
allowed, Just Integer
l) -> Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
allowed Bool -> Bool -> Bool
&& IndexerRead -> Maybe Integer
irMaxLagSlots IndexerRead
ir Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
allowed
            (Maybe Integer, Maybe Integer)
_ -> Bool
False

{- | The bound a take on an existing registry owes every node-judged
transaction: the operator's explicit allowance is on the receipt (a missing
one is a failure, never a pass), and the body states its total collateral
within it and returns the rest.
-}
collateralBoundedRequired :: Receipt -> [String]
collateralBoundedRequired :: Receipt -> [[Char]]
collateralBoundedRequired Receipt
r = case Receipt -> Maybe Integer
rcAllowance Receipt
r of
    Maybe Integer
Nothing ->
        [ [Char]
"no collateral allowance was set for the transaction, so the collateral it puts at risk is not bounded"
        ]
    Just Integer
_ -> Receipt -> [[Char]]
collateralBounded Receipt
r

{- | A retraction, against the insertion's receipt that names the request and
the readbacks on either side of it: the request that receipt names is the one
the retained body spends and the one that left, no other left, the root did
not move, and the wallet holds exactly the bond released less the fee paid.
-}
reclaimed :: Receipt -> Receipt -> Receipt -> Receipt -> [String]
reclaimed :: Receipt -> Receipt -> Receipt -> Receipt -> [[Char]]
reclaimed Receipt
partial Receipt
before Receipt
r Receipt
after =
    [ [Char]
"the retraction's outcome is "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r)
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not accepted"
    | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"accepted"
    ]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
submitted Receipt
r
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
collateralBoundedRequired Receipt
r
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the retraction names the request "
                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Text -> [Char]) -> Maybe Text -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none" Text -> [Char]
T.unpack (Receipt -> Maybe Text
rcPendingRequest Receipt
r)
                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not the "
                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Text -> [Char]) -> Maybe Text -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none" Text -> [Char]
T.unpack (Receipt -> Maybe Text
rcPendingRequest Receipt
partial)
                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" the insertion's receipt names"
           | Receipt -> Maybe Text
rcPendingRequest Receipt
r Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Receipt -> Maybe Text
rcPendingRequest Receipt
partial
           ]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case (Receipt -> Maybe Text
rcPendingRequest Receipt
partial, Receipt -> Maybe Account
rcAccount Receipt
r) of
            (Just Text
p, Just Account
a) ->
                [ [Char]
"the retained body does not spend the request "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
p
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" the insertion's receipt names"
                | (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
p) (Account -> [Text]
acSpends Account
a) [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text
p]
                ]
            (Maybe Text, Maybe Account)
_ ->
                [ [Char]
"the insertion's receipt names no request, or the retraction records no body to read its spends from"
                ]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case ( Receipt -> Maybe Observation
rcObservation Receipt
before
                , Receipt -> Maybe Observation
rcObservation Receipt
after
                , Receipt -> Maybe Text
rcPendingRequest Receipt
r
                , Receipt -> Maybe Account
rcAccount Receipt
r
                ) of
            (Just Observation
x, Just Observation
y, Just Text
p, Just Account
a) ->
                [ [Char]
"the request "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
p
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" was not pending before the retraction"
                | Text
p Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Observation -> [Text]
obPending Observation
x
                ]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the request "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
p
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is still pending after the retraction"
                       | Text
p Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Observation -> [Text]
obPending Observation
y
                       ]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"a request other than the retracted one left: "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> [Char]
forall a. Show a => a -> [Char]
show ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Observation -> [Text]
obPending Observation
y) (Observation -> [Text]
obPending Observation
x))
                       | (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Observation -> [Text]
obPending Observation
y) (Observation -> [Text]
obPending Observation
x) [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text
p]
                       ]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"the registry's root moved" | Observation -> Text
obRoot Observation
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Observation -> Text
obRoot Observation
y]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the wallet holds "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show (Observation -> Integer
obWalletLovelace Observation
y)
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not the "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show (Observation -> Integer
obWalletLovelace Observation
x)
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" it held plus the "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
released
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" the request released less the "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show (Account -> Integer
acFee Account
a)
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" the retraction paid"
                       | Observation -> Integer
obWalletLovelace Observation
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Observation -> Integer
obWalletLovelace Observation
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
released Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Account -> Integer
acFee Account
a
                       ]
              where
                released :: Integer
released = Observation -> Integer
obPendingLovelace Observation
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Observation -> Integer
obPendingLovelace Observation
y
            (Maybe Observation, Maybe Observation, Maybe Text, Maybe Account)
_ ->
                [ [Char]
"the retraction names no pending request, records no fee, or a readback carries no observation"
                ]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the readbacks are of other registries or keys"
           | (Receipt -> Text
rcTarget Receipt
before, Receipt -> Text
rcKey Receipt
before) (Text, Text) -> (Text, Text) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Receipt -> Text
rcTarget Receipt
after, Receipt -> Text
rcKey Receipt
after)
           ]

-- | The requirement's failures on these receipts; none means it holds.
check :: Requirement -> [Receipt] -> [String]
check :: Requirement -> [Receipt] -> [[Char]]
check Requirement
req [Receipt]
rs = case (Requirement
req, [Receipt]
rs) of
    (Requirement
Established, cs :: [Receipt]
cs@(Receipt
_ : [Receipt]
_)) ->
        (Receipt -> [[Char]]) -> [Receipt] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Receipt
c -> [Char] -> Receipt -> [[Char]]
succeeded ([Char]
"the " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Receipt -> Text
rcAction Receipt
c)) Receipt
c) [Receipt]
cs
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Receipt] -> [[Char]]
oneRegistry [Receipt]
cs
    (Requirement
ReachedActive, Receipt
_ : [Receipt]
_) -> Text -> [Receipt] -> [[Char]]
reachedLeaf Text
"active" [Receipt]
rs
    (Requirement
ReachedTerminal, Receipt
_ : [Receipt]
_) -> Text -> [Receipt] -> [[Char]]
reachedLeaf Text
"terminal" [Receipt]
rs
    (Requirement
RejectedBeforeScripts, [Receipt
r]) ->
        [ [Char]
"the outcome is "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not a rejection by the node"
        | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"ledger-refused"
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case Receipt -> Maybe Text
rcApplication Receipt
r of
                Maybe Text
Nothing -> [[Char]
"the applied open-datum script is not recorded"]
                Just Text
h -> case Text -> Receipt -> Either RefusalMismatch ()
attribution Text
h Receipt
r of
                    Left (NotPhase2 [Char]
_) ->
                        [ [Char]
"the rejection does not name the open-datum script, so it does not test the attribution"
                        | Text
h Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Receipt -> [Text]
rcRefusingScripts Receipt
r
                        ]
                    Either RefusalMismatch ()
_ ->
                        [ [Char]
"a script executed and failed; this is not a rejection before any script ran"
                        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
submitted Receipt
r
    (Requirement
Observed, [Receipt
r]) ->
        [ [Char]
"the readback's outcome is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not observed"
        | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"observed"
        ]
    (Requirement
RefusedByApplication, [Receipt
r]) ->
        [ [Char]
"the transaction was evaluated locally, so the node never judged it"
        | Receipt -> Maybe Text
rcEvaluation Receipt
r Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"skipped"
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the outcome is "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r)
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not a refusal by the node"
               | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"ledger-refused"
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Text -> Receipt -> [[Char]]
attributedTo [Char]
"applied open-datum script" (Receipt -> Maybe Text
rcApplication Receipt
r) Receipt
r
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
collateralBounded Receipt
r
    (Requirement
RegistryUnchanged, [Receipt
a, Receipt
b]) -> case (Receipt -> Maybe Observation
rcObservation Receipt
a, Receipt -> Maybe Observation
rcObservation Receipt
b) of
        (Just Observation
x, Just Observation
y) ->
            [[Char]
"the registry's root moved" | Observation -> Text
obRoot Observation
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Observation -> Text
obRoot Observation
y]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the pending requests changed"
                   | (Observation -> [Text]
obPending Observation
x, Observation -> Integer
obPendingLovelace Observation
x)
                        ([Text], Integer) -> ([Text], Integer) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Observation -> [Text]
obPending Observation
y, Observation -> Integer
obPendingLovelace Observation
y)
                   ]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"the wallet changed" | Observation -> Integer
obWalletLovelace Observation
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Observation -> Integer
obWalletLovelace Observation
y]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the readbacks are of different registries"
                   | Receipt -> Text
rcTarget Receipt
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Receipt -> Text
rcTarget Receipt
b
                   ]
        (Maybe Observation, Maybe Observation)
_ -> [[Char]
"a readback carries no observation"]
    (Requirement
HoldingUnchanged, [Receipt
a, Receipt
b]) -> case (Receipt -> Maybe Observation
rcObservation Receipt
a, Receipt -> Maybe Observation
rcObservation Receipt
b) of
        (Just Observation
x, Just Observation
y) ->
            [[Char]
"the registry's root moved" | Observation -> Text
obRoot Observation
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Observation -> Text
obRoot Observation
y]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the key's holding changed"
                   | (Observation -> Maybe Text
obHolding Observation
x, Observation -> Maybe Integer
obHoldingLovelace Observation
x)
                        (Maybe Text, Maybe Integer) -> (Maybe Text, Maybe Integer) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Observation -> Maybe Text
obHolding Observation
y, Observation -> Maybe Integer
obHoldingLovelace Observation
y)
                   ]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"the wallet changed" | Observation -> Integer
obWalletLovelace Observation
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Observation -> Integer
obWalletLovelace Observation
y]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"the key has no live holding to protect" | Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Observation -> Maybe Text
obHolding Observation
y)]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the readbacks are of different registries or keys"
                   | (Receipt -> Text
rcTarget Receipt
a, Receipt -> Text
rcKey Receipt
a) (Text, Text) -> (Text, Text) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Receipt -> Text
rcTarget Receipt
b, Receipt -> Text
rcKey Receipt
b)
                   ]
        (Maybe Observation, Maybe Observation)
_ -> [[Char]
"a readback carries no observation"]
    (Requirement
TokenOnlyReading, [Receipt
mine, Receipt
theirs]) ->
        [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the actor's own inspect" Receipt
mine
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the second actor's inspect" Receipt
theirs
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the registry's root"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
mine)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
theirs)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the key's leaf"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
mine)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
theirs)
    (Requirement
FoldConsumed, [Receipt
booking, Receipt
folded, Receipt
seen]) ->
        [ [Char]
"the booking's outcome is "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
booking)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not accepted"
        | Receipt -> Text
rcOutcome Receipt
booking Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"accepted"
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
submitted Receipt
booking
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the token-only fold's settled list is not exactly the one pending request"
               | Bool -> Bool
not (Receipt -> Bool
settledIsSingleton Receipt
folded)
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the token-only fold" Receipt
folded
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the folded request"
                (Text -> Value
Aeson.String (Text -> Value) -> (Text -> Text) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#0") (Text -> Value) -> Maybe Text -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Receipt -> Maybe Text
rcTxId Receipt
booking)
                (Text -> Receipt -> Maybe Value
settledField Text
"request" Receipt
folded)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the fold is of another key"
               | Receipt -> Text
rcKey Receipt
booking Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Receipt -> Text
rcKey Receipt
folded
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the token-only inspect" Receipt
seen
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the inspect is of another key"
               | Receipt -> Text
rcKey Receipt
folded Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Receipt -> Text
rcKey Receipt
seen
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is [Char]
"the key's leaf" Value
"active" ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
seen)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the holding's inline envelope"
                (Text -> Receipt -> Maybe Value
settlementField Text
"envelope" Receipt
folded)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"envelope"] Receipt
seen)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the registry's root"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
folded)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
seen)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the fold names no usable folder"
               | Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Value -> Maybe Text
usableIdentity ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"folder"] Receipt
folded))
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the inspect names no usable holding controller"
               | Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing
                    ( Maybe Value -> Maybe Text
usableIdentity
                        ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"controller"] Receipt
seen)
                    )
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the token-only fold was funded by the booking controller's own wallet"
               | Just Text
f <- [Maybe Value -> Maybe Text
usableIdentity ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"folder"] Receipt
folded)]
               , Just Text
c <-
                    [ Maybe Value -> Maybe Text
usableIdentity
                        ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"controller"] Receipt
seen)
                    ]
               , Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
c
               ]
    (Requirement
SameRegistry, [Receipt
c, Receipt
i]) ->
        [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the create" Receipt
c
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the insert" Receipt
i
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the insert's settled list is not exactly the one pending request"
               | Bool -> Bool
not (Receipt -> Bool
settledIsSingleton Receipt
i)
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the registry's state policy"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"pins", Text -> Either Text Int
field Text
"pinState"] Receipt
c)
                ( [Either Text Int] -> Receipt -> Maybe Value
at
                    ( [Either Text Int]
settledControlPath
                        [Either Text Int] -> [Either Text Int] -> [Either Text Int]
forall a. Semigroup a => a -> a -> a
<> [Int -> Either Text Int
forall a b. b -> Either a b
Right Int
1, Text -> Either Text Int
field Text
"fields", Int -> Either Text Int
forall a b. b -> Either a b
Right Int
0, Text -> Either Text Int
field Text
"bytes"]
                    )
                    Receipt
i
                )
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the registry's state token"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"token"] Receipt
c)
                ( [Either Text Int] -> Receipt -> Maybe Value
at
                    ( [Either Text Int]
settledControlPath
                        [Either Text Int] -> [Either Text Int] -> [Either Text Int]
forall a. Semigroup a => a -> a -> a
<> [Int -> Either Text Int
forall a b. b -> Either a b
Right Int
1, Text -> Either Text Int
field Text
"fields", Int -> Either Text Int
forall a b. b -> Either a b
Right Int
1, Text -> Either Text Int
field Text
"bytes"]
                    )
                    Receipt
i
                )
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the registry's active policy"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"pins", Text -> Either Text Int
field Text
"pinActive"] Receipt
c)
                ([Either Text Int] -> Receipt -> Maybe Value
at ([Either Text Int]
settledControlPath [Either Text Int] -> [Either Text Int] -> [Either Text Int]
forall a. Semigroup a => a -> a -> a
<> [Int -> Either Text Int
forall a b. b -> Either a b
Right Int
2, Text -> Either Text Int
field Text
"bytes"]) Receipt
i)
    (Requirement
Delivered, [Receipt
i, Receipt
s]) ->
        [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the insert" Receipt
i
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the insert's settled list is not exactly the one pending request"
               | Bool -> Bool
not (Receipt -> Bool
settledIsSingleton Receipt
i)
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the inspect" Receipt
s
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is [Char]
"the key's leaf" Value
"active" ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
s)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the holding's output"
                (Text -> Receipt -> Maybe Value
settlementField Text
"liveOutput" Receipt
i)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"output"] Receipt
s)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the holding's inline envelope"
                (Text -> Receipt -> Maybe Value
settlementField Text
"envelope" Receipt
i)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"envelope"] Receipt
s)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case ( [Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"lovelace"] Receipt
s
                    , [Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"deposit"] Receipt
s
                    ) of
                (Just (Aeson.Number Scientific
l), Just (Aeson.Number Scientific
d))
                    | Scientific
l Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
>= Scientific
d -> []
                    | Bool
otherwise -> [[Char]
"the holding holds less than its protected deposit"]
                (Maybe Value, Maybe Value)
_ -> [[Char]
"the holding's lovelace or deposit is not read back"]
    (Requirement
PayloadReplaced, [Receipt
b, Receipt
u, Receipt
a]) ->
        [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the update" Receipt
u
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the inspect before" Receipt
b
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the inspect after" Receipt
a
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the root across the update"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
b)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
a)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the root the update reports"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
b)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
u)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the payload"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"payload"] Receipt
u)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"payload"] Receipt
a)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the holding's output"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"liveOutput"] Receipt
u)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"output"] Receipt
a)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the controller"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"controller"] Receipt
b)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"controller"] Receipt
a)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the protected deposit"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"deposit"] Receipt
b)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"deposit"] Receipt
a)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is [Char]
"the key's leaf" Value
"active" ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
a)
    (Requirement
Released, [Receipt
b, Receipt
t, Receipt
a]) ->
        [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the terminate" Receipt
t
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the terminate's settled list is not exactly the one pending request"
               | Bool -> Bool
not (Receipt -> Bool
settledIsSingleton Receipt
t)
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the inspect after" Receipt
a
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is [Char]
"the key's leaf" Value
"terminal" ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
a)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is
                [Char]
"the key's holdings"
                (Array -> Value
Aeson.Array Array
forall a. Monoid a => a
mempty)
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"holdings"] Receipt
a)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                [Char]
"the released deposit"
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"applicationOutput", Text -> Either Text Int
field Text
"deposit"] Receipt
b)
                (Text -> Receipt -> Maybe Value
settlementField Text
"deposit" Receipt
t)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case Text -> Receipt -> Maybe Value
settlementField Text
"released" Receipt
t of
                Just (Aeson.String Text
_) -> []
                Maybe Value
_ -> [[Char]
"the terminate names no released output"]
    (Requirement
CommandSucceeded, [Receipt
r]) -> [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the command" Receipt
r
    (Requirement
Reclaimed, [Receipt
p, Receipt
b, Receipt
r, Receipt
a]) -> Receipt -> Receipt -> Receipt -> Receipt -> [[Char]]
reclaimed Receipt
p Receipt
b Receipt
r Receipt
a
    (Requirement
ExposureBounded, [Receipt
r]) -> Receipt -> [[Char]]
collateralBoundedRequired Receipt
r
    (Requirement
IndexerAgrees, [Receipt
i, Receipt
r]) -> Receipt -> Receipt -> [[Char]]
indexerAgrees Receipt
i Receipt
r
    (Requirement
Accepted, [Receipt
r]) ->
        [ [Char]
"the outcome is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not accepted"
        | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"accepted"
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
submitted Receipt
r
    (Requirement
RefusedByState, [Receipt
r]) ->
        [ [Char]
"the fold was evaluated locally, so the node never judged it"
        | Receipt -> Maybe Text
rcEvaluation Receipt
r Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"skipped"
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the outcome is "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r)
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not a refusal by the node"
               | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"ledger-refused"
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Text -> Receipt -> [[Char]]
attributedTo [Char]
"registry's state validator" (Receipt -> Maybe Text
rcStateValidator Receipt
r) Receipt
r
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
collateralBounded Receipt
r
    (Requirement
BookingRefused, [Receipt
c, Receipt
o]) ->
        [ [Char]
"the command's outcome is "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
c)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not client-refusal"
        | Receipt -> Text
rcOutcome Receipt
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"client-refusal"
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the command names a pending request"
               | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Receipt -> Maybe Text
rcPendingRequest Receipt
c)
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the refused command submitted "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([Submission] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Receipt -> [Submission]
rcSubmissions Receipt
c))
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" transactions"
               | Bool -> Bool
not ([Submission] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Receipt -> [Submission]
rcSubmissions Receipt
c))
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case Receipt -> Maybe JournalSpan
rcJournal Receipt
c of
                Maybe JournalSpan
Nothing -> []
                Just JournalSpan
js ->
                    [ [Char]
"the registry's journal moved from "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (JournalSpan -> Int
jsBefore JournalSpan
js)
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" to "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (JournalSpan -> Int
jsAfter JournalSpan
js)
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" lines"
                    | JournalSpan -> Int
jsAfter JournalSpan
js Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= JournalSpan -> Int
jsBefore JournalSpan
js
                    ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
c
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is
                [Char]
"the refusal's policy"
                (Text -> Value
Aeson.String Text
"client")
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"policy"] Receipt
c)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is
                [Char]
"the refusal's verb"
                (Text -> Value
Aeson.String (Text -> Text
bookingVerb (Receipt -> Text
rcAction Receipt
c)))
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"verb"] Receipt
c)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is
                [Char]
"the refused key"
                (Text -> Value
Aeson.String ([Char] -> Text
hexLabel (Text -> [Char]
T.unpack (Receipt -> Text
rcKey Receipt
c))))
                ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"key"] Receipt
c)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case (Receipt -> Maybe Text
rcReason Receipt
c, Receipt -> Maybe Observation
rcObservation Receipt
o) of
                (Maybe Text
Nothing, Maybe Observation
_) -> [[Char]
"the refusal names no reason"]
                (Maybe Text
_, Maybe Observation
Nothing) -> [[Char]
"the readback carries no observation"]
                (Just Text
reason, Just Observation
seen) ->
                    Text -> Text -> Text -> Observation -> [[Char]]
bookingReason (Receipt -> Text
rcAction Receipt
c) (Receipt -> Text
rcKey Receipt
c) Text
reason Observation
seen
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the readback is of another registry or key"
                           | -- A refusal run by token names the actor as its target
                           -- while its readback names the registry: same key with
                           -- a by-token action is that actor's refusal against that
                           -- registry's readback. The token link itself is the story's
                           -- wiring, not a receipt field (documented limit).
                           Receipt -> Text
rcKey Receipt
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Receipt -> Text
rcKey Receipt
o
                            Bool -> Bool -> Bool
|| (Receipt -> Text
rcTarget Receipt
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Receipt -> Text
rcTarget Receipt
o Bool -> Bool -> Bool
&& Bool -> Bool
not (Text
"by token" Text -> Text -> Bool
`T.isSuffixOf` Receipt -> Text
rcAction Receipt
c))
                           ]
    (Requirement
Unchanged, [Receipt
a, Receipt
b]) -> case (Receipt -> Maybe Observation
rcObservation Receipt
a, Receipt -> Maybe Observation
rcObservation Receipt
b) of
        (Just Observation
x, Just Observation
y) ->
            [ [Char]
"the registry's root moved"
            | Observation -> Text
obRoot Observation
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Observation -> Text
obRoot Observation
y
            ]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the key's holding changed"
                   | (Observation -> Maybe Text
obHolding Observation
x, Observation -> Maybe Integer
obHoldingLovelace Observation
x)
                        (Maybe Text, Maybe Integer) -> (Maybe Text, Maybe Integer) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Observation -> Maybe Text
obHolding Observation
y, Observation -> Maybe Integer
obHoldingLovelace Observation
y)
                   ]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the pending requests changed"
                   | (Observation -> [Text]
obPending Observation
x, Observation -> Integer
obPendingLovelace Observation
x)
                        ([Text], Integer) -> ([Text], Integer) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Observation -> [Text]
obPending Observation
y, Observation -> Integer
obPendingLovelace Observation
y)
                   ]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the wallet changed"
                   | Observation -> Integer
obWalletLovelace Observation
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Observation -> Integer
obWalletLovelace Observation
y
                   ]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"no booking is pending, so nothing was refused"
                   | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Observation -> [Text]
obPending Observation
y)
                   ]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the readbacks are of different registries or keys"
                   | (Receipt -> Text
rcTarget Receipt
a, Receipt -> Text
rcKey Receipt
a) (Text, Text) -> (Text, Text) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Receipt -> Text
rcTarget Receipt
b, Receipt -> Text
rcKey Receipt
b)
                   ]
        (Maybe Observation, Maybe Observation)
_ -> [[Char]
"a readback carries no observation"]
    (Requirement
PartialPending, [Receipt
c, Receipt
o]) ->
        [ [Char]
"the command's outcome is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
c) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not partial"
        | Receipt -> Text
rcOutcome Receipt
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"partial"
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"the command: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) (Receipt -> [[Char]]
admitted Receipt
c)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case (Receipt -> Maybe Text
rcPendingRequest Receipt
c, Receipt -> Maybe Observation
rcObservation Receipt
o) of
                (Maybe Text
Nothing, Maybe Observation
_) -> [[Char]
"the command names no pending request"]
                (Maybe Text
_, Maybe Observation
Nothing) -> [[Char]
"the readback carries no observation"]
                (Just Text
p, Just Observation
seen) ->
                    [ [Char]
"the request " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
p [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" the command names is not pending"
                    | Text
p Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Observation -> [Text]
obPending Observation
seen
                    ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the readback is of another registry"
               | Receipt -> Text
rcTarget Receipt
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Receipt -> Text
rcTarget Receipt
o
               ]
    (Requirement
RefusedBeforeSubmitting, [Receipt
r]) ->
        Receipt -> Text -> [[Char]]
outcomeIs Receipt
r (Receipt -> Text
expectedOutcome Receipt
r)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess Receipt
r (\ProcessEvidence
p -> ProcessEvidence -> [[Char]]
journalStill ProcessEvidence
p [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> ProcessEvidence -> [[Char]]
nothingSubmitted Receipt
r ProcessEvidence
p)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
    (Requirement
NoLeafPrinted, [Receipt
r])
        | Receipt -> Text
rcAction Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"provoke inspect-without-history" ->
            Receipt -> [[Char]]
withheldHistory Receipt
r [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
        | Bool
otherwise -> Receipt -> [[Char]]
noLeaf Receipt
r [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
    (Requirement
StoppedAfterAcceptance, [Receipt
r]) ->
        Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess
            Receipt
r
            ( \ProcessEvidence
p ->
                [ [Char]
"the process was not killed: it exited " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (ProcessEvidence -> Int
peExit ProcessEvidence
p)
                | ProcessEvidence -> Int
peExit ProcessEvidence
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
                ]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the journal's last line when it stopped is "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (ProcessEvidence -> Text
peLastEvent ProcessEvidence
p)
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not the node's acceptance of its "
                            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Receipt -> Text
killedStep Receipt
r)
                       | ProcessEvidence -> Text
peLastEvent ProcessEvidence
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Receipt -> Text
killedStep Receipt
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/submitted"
                       ]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case [Text] -> [Text]
forall a. [a] -> [a]
reverse (ProcessEvidence -> [Text]
peSubmitted ProcessEvidence
p) of
                        [] -> [[Char]
"the journal records no submission of the command"]
                        Text
t : [Text]
_ ->
                            [ [Char]
"the accepted transaction "
                                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
t
                                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" has no kept body"
                            | Text
t Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Submission -> Text) -> [Submission] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Submission -> Text
suTxId (Receipt -> [Submission]
rcSubmissions Receipt
r)
                            ]
            )
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
    (Requirement
ReconciledOrRefused, [Receipt
killed, Receipt
r]) ->
        Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess Receipt
killed ((ProcessEvidence -> [[Char]]) -> [[Char]])
-> (ProcessEvidence -> [[Char]]) -> [[Char]]
forall a b. (a -> b) -> a -> b
$ \ProcessEvidence
pk -> case [Text] -> [Text]
forall a. [a] -> [a]
reverse (ProcessEvidence -> [Text]
peSubmitted ProcessEvidence
pk) of
            [] -> [[Char]
"the killed command's journal records no submission"]
            Text
t : [Text]
_ -> case Receipt -> Text
rcOutcome Receipt
r of
                Text
"success" ->
                    [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the update" Receipt
r
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                            [Char]
"the replayed root and the included fold's chain root"
                            ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
r)
                            (Text -> Value
Aeson.String (Text -> Value) -> (Observation -> Text) -> Observation -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Observation -> Text
obRoot (Observation -> Value) -> Maybe Observation -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Receipt -> Maybe Observation
rcObservation Receipt
killed)
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the killed fold was submitted again"
                           | Text
t Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Submission -> Text) -> [Submission] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Submission -> Text
suTxId (Receipt -> [Submission]
rcSubmissions Receipt
r)
                           ]
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the update did not observe the killed fold " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
t
                           | Text
t Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Maybe Value -> [Text]
strings ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"reconciled", Text -> Either Text Int
field Text
"observed"] Receipt
r)
                           ]
                Text
"partial" ->
                    Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess Receipt
r (\ProcessEvidence
p -> ProcessEvidence -> [[Char]]
journalStill ProcessEvidence
p [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> ProcessEvidence -> [[Char]]
nothingSubmitted Receipt
r ProcessEvidence
p)
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is
                            [Char]
"the refused transaction"
                            (Text -> Value
Aeson.String Text
t)
                            ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"unresolved", Text -> Either Text Int
field Text
"tx"] Receipt
r)
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is
                            [Char]
"the refused transaction's case"
                            Value
"acknowledged"
                            ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"unresolved", Text -> Either Text Int
field Text
"case"] Receipt
r)
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
                Text
other ->
                    [ [Char]
"the outcome is "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
other
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", neither success nor partial"
                    ]
    (Requirement
ResolvedFromChain, [Receipt
killed, Receipt
updated, Receipt
seen]) ->
        [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the inspect" Receipt
seen
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is [Char]
"the key's leaf" Value
"terminal" ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
seen)
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess
                Receipt
killed
                ( \ProcessEvidence
pk -> case [Text] -> [Text]
forall a. [a] -> [a]
reverse (ProcessEvidence -> [Text]
peSubmitted ProcessEvidence
pk) of
                    [] -> [[Char]
"the killed command's journal records no submission"]
                    Text
t : [Text]
_ ->
                        let times :: [Char] -> [Text] -> [[Char]]
times [Char]
what [Text]
xs =
                                [ [Char]
"the killed fold "
                                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
t
                                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" was "
                                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
what
                                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" "
                                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
                                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" times, not once"
                                | let n :: Int
n = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t) [Text]
xs)
                                , Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
                                ]
                        in  [Char] -> [Text] -> [[Char]]
times
                                [Char]
"observed"
                                ( Maybe Value -> [Text]
strings ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"reconciled", Text -> Either Text Int
field Text
"observed"] Receipt
updated)
                                    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Maybe Value -> [Text]
strings ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"observed"] Receipt
seen)
                                )
                                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the killed fold was submitted again"
                                   | Text
t
                                        Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ( (Submission -> Text) -> [Submission] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Submission -> Text
suTxId (Receipt -> [Submission]
rcSubmissions Receipt
updated [Submission] -> [Submission] -> [Submission]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [Submission]
rcSubmissions Receipt
seen)
                                                    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
-> (ProcessEvidence -> [Text]) -> Maybe ProcessEvidence -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ProcessEvidence -> [Text]
peSubmitted (Receipt -> Maybe ProcessEvidence
rcProcess Receipt
updated)
                                                    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
-> (ProcessEvidence -> [Text]) -> Maybe ProcessEvidence -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ProcessEvidence -> [Text]
peSubmitted (Receipt -> Maybe ProcessEvidence
rcProcess Receipt
seen)
                                               )
                                   ]
                                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                                    [Char]
"the replayed root and the included fold's chain root"
                                    ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
seen)
                                    (Text -> Value
Aeson.String (Text -> Value) -> (Observation -> Text) -> Observation -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Observation -> Text
obRoot (Observation -> Value) -> Maybe Observation -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Receipt -> Maybe Observation
rcObservation Receipt
killed)
                                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Maybe Value -> Maybe Value -> [[Char]]
same
                                    [Char]
"the replayed root and inspect's chain root"
                                    ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"root"] Receipt
seen)
                                    (Text -> Value
Aeson.String (Text -> Value) -> (Observation -> Text) -> Observation -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Observation -> Text
obRoot (Observation -> Value) -> Maybe Observation -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Receipt -> Maybe Observation
rcObservation Receipt
seen)
                )
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
killed
    (Requirement
IncompleteCreateRead, [Receipt
killed, Receipt
seen]) ->
        Receipt -> Text -> [[Char]]
outcomeIs Receipt
seen Text
"partial"
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the inspect did not read the incomplete create's seed"
               | [Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"incompleteCreate", Text -> Either Text Int
field Text
"seed"] Receipt
seen
                    Maybe Value -> [Maybe Value] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe Value
forall a. Maybe a
Nothing, Value -> Maybe Value
forall a. a -> Maybe a
Just Value
Aeson.Null]
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the inspect printed a leaf for an incomplete create"
               | [Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
seen 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
Aeson.Null]
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> Receipt -> ([Text] -> [Text]) -> [[Char]]
observedKilled Receipt
killed Receipt
seen [Text] -> [Text]
forall a. a -> a
id
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
seen
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
killed
    (Requirement
LateCreateRefused, [Receipt
r]) ->
        Receipt -> Text -> [[Char]]
outcomeIs Receipt
r Text
"client-refusal"
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the refusal is not that the registry exists: "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Text -> [Char]) -> Maybe Text -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"no reason" Text -> [Char]
T.unpack (Receipt -> Maybe Text
rcReason Receipt
r)
               | Bool -> Bool
not
                    ( Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                        Bool
False
                        ( Text
"already holds your state or its journal; create never overwrites one"
                            Text -> Text -> Bool
`T.isSuffixOf`
                        )
                        (Receipt -> Maybe Text
rcReason Receipt
r)
                    )
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess
                Receipt
r
                ( \ProcessEvidence
p ->
                    [ [Char]
"the first registry's saved files are not recorded"
                    | [(Text, Text)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ProcessEvidence -> [(Text, Text)]
peFilesBefore ProcessEvidence
p)
                    ]
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the first registry's saved files changed"
                           | [(Text, Text)] -> [(Text, Text)]
byName (ProcessEvidence -> [(Text, Text)]
peFilesBefore ProcessEvidence
p) [(Text, Text)] -> [(Text, Text)] -> Bool
forall a. Eq a => a -> a -> Bool
/= [(Text, Text)] -> [(Text, Text)]
byName (ProcessEvidence -> [(Text, Text)]
peFilesAfter ProcessEvidence
p)
                           ]
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the late wallet's seed was not probed afterwards"
                           | Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (ProcessEvidence -> Maybe Text
peSeedProbe ProcessEvidence
p)
                           ]
                )
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
    (Requirement
CreateUnderfunded, [Receipt
r]) ->
        Receipt -> Text -> [[Char]]
outcomeIs Receipt
r Text
"client-refusal"
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the refusal is not publication funding: "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Text -> [Char]) -> Maybe Text -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"no reason" Text -> [Char]
T.unpack (Receipt -> Maybe Text
rcReason Receipt
r)
               | Bool -> Bool
not
                    ( Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                        Bool
False
                        (Text
"publication-unfunded" Text -> Text -> Bool
`T.isPrefixOf`)
                        (Receipt -> Maybe Text
rcReason Receipt
r)
                    )
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess
                Receipt
r
                ( \ProcessEvidence
p ->
                    ProcessEvidence -> [[Char]]
journalStill ProcessEvidence
p
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> ProcessEvidence -> [[Char]]
nothingSubmitted Receipt
r ProcessEvidence
p
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the refused create wrote to its directory"
                           | [(Text, Text)] -> [(Text, Text)]
byName (ProcessEvidence -> [(Text, Text)]
peFilesBefore ProcessEvidence
p) [(Text, Text)] -> [(Text, Text)] -> Bool
forall a. Eq a => a -> a -> Bool
/= [(Text, Text)] -> [(Text, Text)]
byName (ProcessEvidence -> [(Text, Text)]
peFilesAfter ProcessEvidence
p)
                           ]
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the underfunded wallet's seed was not probed afterwards"
                           | Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (ProcessEvidence -> Maybe Text
peSeedProbe ProcessEvidence
p)
                           ]
                )
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
    (Requirement
BoundedAfterNodeLoss, [Receipt
r]) ->
        [ [Char]
"the outcome is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not partial or timeout"
        | Receipt -> Text
rcOutcome Receipt
r Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"partial", Text
"timeout"]
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> (ProcessEvidence -> [[Char]]) -> [[Char]]
withProcess
                Receipt
r
                ( \ProcessEvidence
p ->
                    [ [Char]
"the command ran "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> (Int -> [Char]) -> Maybe Int -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"an unknown time" (\Int
s -> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
s [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"s") (ProcessEvidence -> Maybe Int
peWaited ProcessEvidence
p)
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" past its release, beyond its 30-second bound and teardown"
                    | Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
90) (ProcessEvidence -> Maybe Int
peWaited ProcessEvidence
p)
                    ]
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"the journal does not keep the submitted update unresolved: its last line is "
                                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (ProcessEvidence -> Text
peLastEvent ProcessEvidence
p)
                           | Bool -> Bool
not (Text
"/unconfirmed" Text -> Text -> Bool
`T.isSuffixOf` ProcessEvidence -> Text
peLastEvent ProcessEvidence
p)
                           ]
                        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case ProcessEvidence -> [Text]
peSubmitted ProcessEvidence
p of
                            [] -> [[Char]
"the journal records no submission of the update"]
                            [Text]
ts ->
                                [ [Char]
"the receipt does not name the submitted transaction"
                                | Bool -> Bool
not ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Text
t -> Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text
t Text -> Text -> Bool
`T.isInfixOf`) (Receipt -> Maybe Text
rcReason Receipt
r)) [Text]
ts)
                                ]
                )
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
admitted Receipt
r
    (Requirement
_, [Receipt]
_) ->
        [ Requirement -> [Char]
forall a. Show a => a -> [Char]
show Requirement
req
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" takes "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ( if Requirement
req
                    Requirement -> [Requirement] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Requirement
Unchanged
                           , Requirement
PartialPending
                           , Requirement
HoldingUnchanged
                           , Requirement
RegistryUnchanged
                           , Requirement
SameRegistry
                           , Requirement
Delivered
                           , Requirement
ReconciledOrRefused
                           , Requirement
IncompleteCreateRead
                           , Requirement
IndexerAgrees
                           ]
                    then [Char]
"two"
                    else
                        if Requirement
req Requirement -> [Requirement] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Requirement
PayloadReplaced, Requirement
Released, Requirement
ResolvedFromChain]
                            then [Char]
"three"
                            else
                                if Requirement
req Requirement -> Requirement -> Bool
forall a. Eq a => a -> a -> Bool
== Requirement
Reclaimed
                                    then [Char]
"four"
                                    else [Char]
"one"
               )
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" receipts, given "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([Receipt] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Receipt]
rs)
        ]

-- ---------------------------------------------------------
-- Judging
-- ---------------------------------------------------------

data ClauseStatus
    = Held
    | NotHeld [String]
    | Uncovered String
    | -- | The promise is retired, for this reason; no receipt judges it
      Retired String
    deriving stock (ClauseStatus -> ClauseStatus -> Bool
(ClauseStatus -> ClauseStatus -> Bool)
-> (ClauseStatus -> ClauseStatus -> Bool) -> Eq ClauseStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClauseStatus -> ClauseStatus -> Bool
== :: ClauseStatus -> ClauseStatus -> Bool
$c/= :: ClauseStatus -> ClauseStatus -> Bool
/= :: ClauseStatus -> ClauseStatus -> Bool
Eq, Int -> ClauseStatus -> ShowS
[ClauseStatus] -> ShowS
ClauseStatus -> [Char]
(Int -> ClauseStatus -> ShowS)
-> (ClauseStatus -> [Char])
-> ([ClauseStatus] -> ShowS)
-> Show ClauseStatus
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClauseStatus -> ShowS
showsPrec :: Int -> ClauseStatus -> ShowS
$cshow :: ClauseStatus -> [Char]
show :: ClauseStatus -> [Char]
$cshowList :: [ClauseStatus] -> ShowS
showList :: [ClauseStatus] -> ShowS
Show)

data ClauseResult = ClauseResult
    { ClauseResult -> [Char]
crStatement :: String
    , ClauseResult -> [Char]
crTitle :: String
    , ClauseResult -> ClauseStatus
crStatus :: ClauseStatus
    }
    deriving stock (ClauseResult -> ClauseResult -> Bool
(ClauseResult -> ClauseResult -> Bool)
-> (ClauseResult -> ClauseResult -> Bool) -> Eq ClauseResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClauseResult -> ClauseResult -> Bool
== :: ClauseResult -> ClauseResult -> Bool
$c/= :: ClauseResult -> ClauseResult -> Bool
/= :: ClauseResult -> ClauseResult -> Bool
Eq, Int -> ClauseResult -> ShowS
[ClauseResult] -> ShowS
ClauseResult -> [Char]
(Int -> ClauseResult -> ShowS)
-> (ClauseResult -> [Char])
-> ([ClauseResult] -> ShowS)
-> Show ClauseResult
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClauseResult -> ShowS
showsPrec :: Int -> ClauseResult -> ShowS
$cshow :: ClauseResult -> [Char]
show :: ClauseResult -> [Char]
$cshowList :: [ClauseResult] -> ShowS
showList :: [ClauseResult] -> ShowS
Show)

-- | Every clause's verdict holds, or its promise is retired.
held :: [ClauseResult] -> Bool
held :: [ClauseResult] -> Bool
held = (ClauseResult -> Bool) -> [ClauseResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ClauseResult
r -> ClauseResult -> ClauseStatus
crStatus ClauseResult
r ClauseStatus -> ClauseStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ClauseStatus
Held Bool -> Bool -> Bool
|| ClauseStatus -> Bool
isRetired (ClauseResult -> ClauseStatus
crStatus ClauseResult
r))

-- | Whether a clause's promise is retired.
isRetired :: ClauseStatus -> Bool
isRetired :: ClauseStatus -> Bool
isRetired ClauseStatus
s = case ClauseStatus
s of
    Retired [Char]
_ -> Bool
True
    ClauseStatus
_ -> Bool
False

{- | Interpret the story over receipts. A receipt answers the action at its
step exactly when it names that action, target and key; the first missing
or misplaced receipt leaves every later clause uncovered, naming why, but
a clause whose promise is retired, which reads retired from its description.
Requirements inside a clause's body fail the clause; its check decides it.
-}
judge :: [Receipt] -> Story () -> [ClauseResult]
judge :: [Receipt] -> Story CliI () -> [ClauseResult]
judge [Receipt]
receipts Story CliI ()
story =
    let byStep :: Map Int [Receipt]
byStep = ([Receipt] -> [Receipt] -> [Receipt])
-> [(Int, [Receipt])] -> Map Int [Receipt]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Receipt] -> [Receipt] -> [Receipt]
forall a. Semigroup a => a -> a -> a
(<>) [(Receipt -> Int
rcStep Receipt
r, [Receipt
r]) | Receipt
r <- [Receipt]
receipts]
        ([ClauseResult]
reached, Maybe [Char]
stop) = Map Int [Receipt]
-> Story CliI () -> ([ClauseResult], Maybe [Char])
replay Map Int [Receipt]
byStep Story CliI ()
story
        names :: [(([Char], [Char]), Maybe [Char])]
names = Story CliI () -> [(([Char], [Char]), Maybe [Char])]
described Story CliI ()
story
        missing :: [(([Char], [Char]), Maybe [Char])]
missing = Int
-> [(([Char], [Char]), Maybe [Char])]
-> [(([Char], [Char]), Maybe [Char])]
forall a. Int -> [a] -> [a]
drop ([ClauseResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClauseResult]
reached) [(([Char], [Char]), Maybe [Char])]
names
        why :: [Char]
why = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"no receipt" Maybe [Char]
stop
    in  [ClauseResult]
reached
            [ClauseResult] -> [ClauseResult] -> [ClauseResult]
forall a. Semigroup a => a -> a -> a
<> [ [Char] -> [Char] -> ClauseStatus -> ClauseResult
ClauseResult [Char]
s [Char]
t (ClauseStatus
-> ([Char] -> ClauseStatus) -> Maybe [Char] -> ClauseStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> ClauseStatus
Uncovered [Char]
why) [Char] -> ClauseStatus
Retired Maybe [Char]
retired)
               | (([Char]
s, [Char]
t), Maybe [Char]
retired) <- [(([Char], [Char]), Maybe [Char])]
missing
               ]

type Receipts = Map.Map Int [Receipt]

-- The replay's state: the next step, the clauses judged, the stop.
data Replay = Replay Int [ClauseResult] (Maybe String)

replay :: Receipts -> Story () -> ([ClauseResult], Maybe String)
replay :: Map Int [Receipt]
-> Story CliI () -> ([ClauseResult], Maybe [Char])
replay Map Int [Receipt]
byStep Story CliI ()
story =
    let Replay Int
_ [ClauseResult]
results Maybe [Char]
stop = (Maybe (), Replay) -> Replay
forall a b. (a, b) -> b
snd (Replay -> Story CliI () -> (Maybe (), Replay)
forall a. Replay -> Story a -> (Maybe a, Replay)
go (Int -> [ClauseResult] -> Maybe [Char] -> Replay
Replay Int
0 [] Maybe [Char]
forall a. Maybe a
Nothing) Story CliI ()
story)
    in  ([ClauseResult] -> [ClauseResult]
forall a. [a] -> [a]
reverse [ClauseResult]
results, Maybe [Char]
stop)
  where
    go :: Replay -> Story a -> (Maybe a, Replay)
    go :: forall a. Replay -> Story a -> (Maybe a, Replay)
go st :: Replay
st@(Replay Int
_ [ClauseResult]
_ (Just [Char]
_)) Story a
_ = (Maybe a
forall a. Maybe a
Nothing, Replay
st)
    go Replay
st Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
a -> (a -> Maybe a
forall a. a -> Maybe a
Just a
a, Replay
st)
        Action CliI b
i :>>= b -> Story a
next -> case Replay -> CliI b -> (Maybe b, Replay)
forall a. Replay -> CliI a -> (Maybe a, Replay)
perform Replay
st CliI b
i of
            (Just b
r, Replay
st') -> Replay -> Story a -> (Maybe a, Replay)
forall a. Replay -> Story a -> (Maybe a, Replay)
go Replay
st' (b -> Story a
next b
r)
            (Maybe b
Nothing, Replay
st') -> (Maybe a
forall a. Maybe a
Nothing, Replay
st')
        Theorem Theorem thm
thm TheoremStory thm CliI b
body :>>= b -> Story a
next ->
            case [Char]
-> Maybe [Char]
-> Replay
-> Program (Clause thm CliI) b
-> (Maybe b, Replay)
forall {k} (thm :: k) a.
[Char]
-> Maybe [Char]
-> Replay
-> Program (Clause thm CliI) a
-> (Maybe a, Replay)
goClauses (BoundObligation -> [Char]
boName (Theorem thm -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem thm
thm)) Maybe [Char]
forall a. Maybe a
Nothing Replay
st (TheoremStory thm CliI b -> Program (Clause thm CliI) b
forall {k} (thm :: k) (act :: * -> *) res.
TheoremStory thm act res -> Program (Clause thm act) res
clauses TheoremStory thm CliI b
body) of
                (Just b
r, Replay
st') -> Replay -> Story a -> (Maybe a, Replay)
forall a. Replay -> Story a -> (Maybe a, Replay)
go Replay
st' (b -> Story a
next b
r)
                (Maybe b
Nothing, Replay
st') -> (Maybe a
forall a. Maybe a
Nothing, Replay
st')

    goClauses
        :: String
        -> Maybe String
        -> Replay
        -> Program (Clause thm CliI) a
        -> (Maybe a, Replay)
    goClauses :: forall {k} (thm :: k) a.
[Char]
-> Maybe [Char]
-> Replay
-> Program (Clause thm CliI) a
-> (Maybe a, Replay)
goClauses [Char]
_ Maybe [Char]
_ st :: Replay
st@(Replay Int
_ [ClauseResult]
_ (Just [Char]
_)) Program (Clause thm CliI) a
_ = (Maybe a
forall a. Maybe a
Nothing, Replay
st)
    goClauses [Char]
name Maybe [Char]
premise Replay
st Program (Clause thm CliI) a
program = case Program (Clause thm CliI) a -> ProgramView (Clause thm CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Program (Clause thm CliI) a
program of
        Return a
a -> (a -> Maybe a
forall a. a -> Maybe a
Just a
a, Replay
st)
        Clause [Char]
title LeanCheck CliI thm b
leanCheck Story CliI b
body :>>= b -> Program (Clause thm CliI) a
next ->
            let (Maybe (b, ([[Char]], Bool, Maybe [Char]))
inner, Replay Int
n [ClauseResult]
rs Maybe [Char]
stop) = Replay
-> Story CliI b
-> (Maybe (b, ([[Char]], Bool, Maybe [Char])), Replay)
forall a.
Replay
-> Story a -> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
collect Replay
st Story CliI b
body
            in  case (Maybe (b, ([[Char]], Bool, Maybe [Char]))
inner, Maybe [Char]
stop) of
                    (Just (b
obs, ([[Char]]
bodyFailures, Bool
_, Maybe [Char]
retired)), Maybe [Char]
Nothing) ->
                        let (Maybe ((), ([[Char]], Bool, Maybe [Char]))
checked, Replay Int
n' [ClauseResult]
_ Maybe [Char]
stop') =
                                Replay
-> Story CliI ()
-> (Maybe ((), ([[Char]], Bool, Maybe [Char])), Replay)
forall a.
Replay
-> Story a -> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
collect (Int -> [ClauseResult] -> Maybe [Char] -> Replay
Replay Int
n [] Maybe [Char]
forall a. Maybe a
Nothing) (LeanCheck CliI thm b -> b -> Story CliI ()
forall {k} (act :: * -> *) (thm :: k) obs.
LeanCheck act thm obs -> obs -> Story act ()
checkAction LeanCheck CliI thm b
leanCheck b
obs)
                            failures :: [[Char]]
failures =
                                [[Char]]
bodyFailures [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
-> (((), ([[Char]], Bool, Maybe [Char])) -> [[Char]])
-> Maybe ((), ([[Char]], Bool, Maybe [Char]))
-> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(()
_, ([[Char]]
fs, Bool
_, Maybe [Char]
_)) -> [[Char]]
fs) Maybe ((), ([[Char]], Bool, Maybe [Char]))
checked
                            isPremise :: Bool
isPremise = Bool
-> (((), ([[Char]], Bool, Maybe [Char])) -> Bool)
-> Maybe ((), ([[Char]], Bool, Maybe [Char]))
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\(()
_, ([[Char]]
_, Bool
p, Maybe [Char]
_)) -> Bool
p) Maybe ((), ([[Char]], Bool, Maybe [Char]))
checked
                            status :: ClauseStatus
status
                                | Just [Char]
why <- Maybe [Char]
retired = [Char] -> ClauseStatus
Retired [Char]
why
                                | Just [Char]
why <- Maybe [Char]
stop' = [Char] -> ClauseStatus
Uncovered [Char]
why
                                | Just [Char]
failed <- Maybe [Char]
premise =
                                    [Char] -> ClauseStatus
Uncovered ([Char]
"its premise does not hold: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
failed)
                                | [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
failures = ClauseStatus
Held
                                | Bool
otherwise = [[Char]] -> ClauseStatus
NotHeld [[Char]]
failures
                            premise' :: Maybe [Char]
premise'
                                | Just [Char]
_ <- Maybe [Char]
premise = Maybe [Char]
premise
                                | Bool
isPremise
                                , NotHeld [[Char]]
why <- ClauseStatus
status =
                                    [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
title [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", because " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"; " [[Char]]
why)
                                | Bool
isPremise
                                , Uncovered [Char]
why <- ClauseStatus
status =
                                    [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
title [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", because " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
why)
                                | Bool
otherwise = Maybe [Char]
forall a. Maybe a
Nothing
                            result :: ClauseResult
result = [Char] -> [Char] -> ClauseStatus -> ClauseResult
ClauseResult [Char]
name [Char]
title ClauseStatus
status
                        in  [Char]
-> Maybe [Char]
-> Replay
-> Program (Clause thm CliI) a
-> (Maybe a, Replay)
forall {k} (thm :: k) a.
[Char]
-> Maybe [Char]
-> Replay
-> Program (Clause thm CliI) a
-> (Maybe a, Replay)
goClauses
                                [Char]
name
                                Maybe [Char]
premise'
                                (Int -> [ClauseResult] -> Maybe [Char] -> Replay
Replay Int
n' (ClauseResult
result ClauseResult -> [ClauseResult] -> [ClauseResult]
forall a. a -> [a] -> [a]
: [ClauseResult]
rs) Maybe [Char]
stop')
                                (b -> Program (Clause thm CliI) a
next b
obs)
                    (Maybe (b, ([[Char]], Bool, Maybe [Char])), Maybe [Char])
_ ->
                        ( Maybe a
forall a. Maybe a
Nothing
                        , Int -> [ClauseResult] -> Maybe [Char] -> Replay
Replay Int
n [ClauseResult]
rs ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"no receipt" Maybe [Char]
stop))
                        )

    {- Walk a program, collecting the failures of the requirements in it and
    whether any of them is a premise the rest of the telling depends on. -}
    collect
        :: Replay
        -> Story a
        -> (Maybe (a, ([String], Bool, Maybe String)), Replay)
    collect :: forall a.
Replay
-> Story a -> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
collect Replay
st0 = Replay
-> ([[Char]], Bool, Maybe [Char])
-> Story a
-> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
forall a.
Replay
-> ([[Char]], Bool, Maybe [Char])
-> Story a
-> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
walk Replay
st0 ([], Bool
False, Maybe [Char]
forall a. Maybe a
Nothing)
      where
        walk
            :: Replay
            -> ([String], Bool, Maybe String)
            -> Story a
            -> (Maybe (a, ([String], Bool, Maybe String)), Replay)
        walk :: forall a.
Replay
-> ([[Char]], Bool, Maybe [Char])
-> Story a
-> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
walk st :: Replay
st@(Replay Int
_ [ClauseResult]
_ (Just [Char]
_)) ([[Char]], Bool, Maybe [Char])
_ Story a
_ = (Maybe (a, ([[Char]], Bool, Maybe [Char]))
forall a. Maybe a
Nothing, Replay
st)
        walk Replay
st acc :: ([[Char]], Bool, Maybe [Char])
acc@([[Char]]
fs, Bool
p, Maybe [Char]
retired) Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
            Return a
a -> ((a, ([[Char]], Bool, Maybe [Char]))
-> Maybe (a, ([[Char]], Bool, Maybe [Char]))
forall a. a -> Maybe a
Just (a
a, ([[Char]], Bool, Maybe [Char])
acc), Replay
st)
            Action (Require Requirement
req [Receipt]
rs) :>>= b -> Story a
next ->
                Replay
-> ([[Char]], Bool, Maybe [Char])
-> Story a
-> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
forall a.
Replay
-> ([[Char]], Bool, Maybe [Char])
-> Story a
-> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
walk
                    Replay
st
                    ([[Char]]
fs [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Requirement -> [Receipt] -> [[Char]]
check Requirement
req [Receipt]
rs, Bool
p Bool -> Bool -> Bool
|| Requirement
req Requirement -> [Requirement] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Requirement]
premises, Maybe [Char]
retired)
                    (b -> Story a
next ())
            Action (Retire [Char]
why) :>>= b -> Story a
next ->
                Replay
-> ([[Char]], Bool, Maybe [Char])
-> Story a
-> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
forall a.
Replay
-> ([[Char]], Bool, Maybe [Char])
-> Story a
-> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
walk Replay
st ([[Char]]
fs, Bool
p, [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
why) (b -> Story a
next ())
            Action CliI b
i :>>= b -> Story a
next -> case Replay -> CliI b -> (Maybe b, Replay)
forall a. Replay -> CliI a -> (Maybe a, Replay)
perform Replay
st CliI b
i of
                (Just b
r, Replay
st') -> Replay
-> ([[Char]], Bool, Maybe [Char])
-> Story a
-> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
forall a.
Replay
-> ([[Char]], Bool, Maybe [Char])
-> Story a
-> (Maybe (a, ([[Char]], Bool, Maybe [Char])), Replay)
walk Replay
st' ([[Char]], Bool, Maybe [Char])
acc (b -> Story a
next b
r)
                (Maybe b
Nothing, Replay
st') -> (Maybe (a, ([[Char]], Bool, Maybe [Char]))
forall a. Maybe a
Nothing, Replay
st')
            Theorem Theorem thm
_ TheoremStory thm CliI b
_ :>>= b -> Story a
_ ->
                (Maybe (a, ([[Char]], Bool, Maybe [Char]))
forall a. Maybe a
Nothing, Replay -> [Char] -> Replay
stopAt Replay
st [Char]
"a statement nested inside a clause")

    perform :: Replay -> CliI a -> (Maybe a, Replay)
    perform :: forall a. Replay -> CliI a -> (Maybe a, Replay)
perform Replay
st CliI a
i = case CliI a
i of
        Require Requirement
_ [Receipt]
_ -> (a -> Maybe a
forall a. a -> Maybe a
Just (), Replay
st)
        Retire [Char]
_ -> (a -> Maybe a
forall a. a -> Maybe a
Just (), Replay
st)
        Run{} -> Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer Replay
st CliI a
CliI Receipt
i
        RunByToken{} -> Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer Replay
st CliI a
CliI Receipt
i
        Book{} -> Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer Replay
st CliI a
CliI Receipt
i
        FoldUnevaluated{} -> Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer Replay
st CliI a
CliI Receipt
i
        Observe{} -> Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer Replay
st CliI a
CliI Receipt
i
        Craft{} -> Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer Replay
st CliI a
CliI Receipt
i
        Provoke{} -> Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer Replay
st CliI a
CliI Receipt
i
        Reclaim{} -> Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer Replay
st CliI a
CliI Receipt
i
        ReadIndexer{} -> Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer Replay
st CliI a
CliI Receipt
i

    answer :: Replay -> CliI Receipt -> (Maybe Receipt, Replay)
    answer :: Replay -> CliI Receipt -> (Maybe Receipt, Replay)
answer st :: Replay
st@(Replay Int
n [ClauseResult]
rs Maybe [Char]
_) CliI Receipt
i = case (CliI Receipt -> Maybe (Text, Text, Text)
forall res. CliI res -> Maybe (Text, Text, Text)
identify CliI Receipt
i, Int -> Map Int [Receipt] -> Maybe [Receipt]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
n Map Int [Receipt]
byStep) of
        (Just (Text
a, Text
t, Text
k), Just [Receipt
r])
            | (Receipt -> Text
rcAction Receipt
r, Receipt -> Text
rcTarget Receipt
r, Receipt -> Text
rcKey Receipt
r) (Text, Text, Text) -> (Text, Text, Text) -> Bool
forall a. Eq a => a -> a -> Bool
== (Text
a, Text
t, Text
k) ->
                (Receipt -> Maybe Receipt
forall a. a -> Maybe a
Just Receipt
r, Int -> [ClauseResult] -> Maybe [Char] -> Replay
Replay (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [ClauseResult]
rs Maybe [Char]
forall a. Maybe a
Nothing)
            | Bool
otherwise ->
                ( Maybe Receipt
forall a. Maybe a
Nothing
                , Replay -> [Char] -> Replay
stopAt
                    Replay
st
                    ( [Char]
"step "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" answers "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Receipt -> [Char]
describeReceipt Receipt
r
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Text, Text, Text) -> [Char]
describe3 (Text
a, Text
t, Text
k)
                    )
                )
        (Just (Text, Text, Text)
ident, Maybe [Receipt]
Nothing) ->
            ( Maybe Receipt
forall a. Maybe a
Nothing
            , Replay -> [Char] -> Replay
stopAt
                Replay
st
                ([Char]
"no receipt for step " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Text, Text, Text) -> [Char]
describe3 (Text, Text, Text)
ident)
            )
        (Just (Text, Text, Text)
_, Just [Receipt]
_) ->
            ( Maybe Receipt
forall a. Maybe a
Nothing
            , Replay -> [Char] -> Replay
stopAt Replay
st ([Char]
"step " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" has more than one receipt")
            )
        (Maybe (Text, Text, Text)
Nothing, Maybe [Receipt]
_) -> (Maybe Receipt
forall a. Maybe a
Nothing, Replay -> [Char] -> Replay
stopAt Replay
st [Char]
"an action with no receipt identity")

    stopAt :: Replay -> [Char] -> Replay
stopAt (Replay Int
n [ClauseResult]
rs Maybe [Char]
_) [Char]
why = Int -> [ClauseResult] -> Maybe [Char] -> Replay
Replay Int
n [ClauseResult]
rs ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
why)

describe3 :: (Text, Text, Text) -> String
describe3 :: (Text, Text, Text) -> [Char]
describe3 (Text
a, Text
t, Text
k) =
    Text -> [Char]
T.unpack Text
a
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" in "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
t
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if Text -> Bool
T.null Text
k then [Char]
"" else [Char]
" for " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
k)

describeReceipt :: Receipt -> String
describeReceipt :: Receipt -> [Char]
describeReceipt Receipt
r = (Text, Text, Text) -> [Char]
describe3 (Receipt -> Text
rcAction Receipt
r, Receipt -> Text
rcTarget Receipt
r, Receipt -> Text
rcKey Receipt
r)

{- | Every clause the story states, in order, with its statement: the
rows a verdict must account for, whether or not a receipt reached them.
The story is walked with placeholder receipts; it never branches on one.
-}
outline :: Story () -> [(String, String)]
outline :: Story CliI () -> [([Char], [Char])]
outline = ((([Char], [Char]), Maybe [Char]) -> ([Char], [Char]))
-> [(([Char], [Char]), Maybe [Char])] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (([Char], [Char]), Maybe [Char]) -> ([Char], [Char])
forall a b. (a, b) -> a
fst ([(([Char], [Char]), Maybe [Char])] -> [([Char], [Char])])
-> (Story CliI () -> [(([Char], [Char]), Maybe [Char])])
-> Story CliI ()
-> [([Char], [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Story CliI () -> [(([Char], [Char]), Maybe [Char])]
described

{- | Every clause the story states, as 'outline' gives it, with the reason
its promise is retired, read from the description itself: a clause whose
body retires its promise is retired whether or not a receipt reaches it.
-}
described :: Story () -> [((String, String), Maybe String)]
described :: Story CliI () -> [(([Char], [Char]), Maybe [Char])]
described Story CliI ()
story = (Int, [(([Char], [Char]), Maybe [Char])])
-> [(([Char], [Char]), Maybe [Char])]
forall a b. (a, b) -> b
snd (Int -> Story CliI () -> (Int, [(([Char], [Char]), Maybe [Char])])
forall a.
Int -> Story a -> (Int, [(([Char], [Char]), Maybe [Char])])
walk Int
0 Story CliI ()
story)
  where
    walk :: Int -> Story a -> (Int, [((String, String), Maybe String)])
    walk :: forall a.
Int -> Story a -> (Int, [(([Char], [Char]), Maybe [Char])])
walk Int
n Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
_ -> (Int
n, [])
        Action CliI b
i :>>= b -> Story a
next -> let (Int
n', b
r) = Int -> CliI b -> (Int, b)
forall a. Int -> CliI a -> (Int, a)
placeholder Int
n CliI b
i in Int -> Story a -> (Int, [(([Char], [Char]), Maybe [Char])])
forall a.
Int -> Story a -> (Int, [(([Char], [Char]), Maybe [Char])])
walk Int
n' (b -> Story a
next b
r)
        Theorem Theorem thm
thm TheoremStory thm CliI b
body :>>= b -> Story a
next ->
            let name :: [Char]
name = BoundObligation -> [Char]
boName (Theorem thm -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem thm
thm)
                (Int
n', [(([Char], [Char]), Maybe [Char])]
rows, b
r) = [Char]
-> Int
-> Program (Clause thm CliI) b
-> (Int, [(([Char], [Char]), Maybe [Char])], b)
forall {k} (thm :: k) a.
[Char]
-> Int
-> Program (Clause thm CliI) a
-> (Int, [(([Char], [Char]), Maybe [Char])], a)
walkClauses [Char]
name Int
n (TheoremStory thm CliI b -> Program (Clause thm CliI) b
forall {k} (thm :: k) (act :: * -> *) res.
TheoremStory thm act res -> Program (Clause thm act) res
clauses TheoremStory thm CliI b
body)
                (Int
n'', [(([Char], [Char]), Maybe [Char])]
rest) = Int -> Story a -> (Int, [(([Char], [Char]), Maybe [Char])])
forall a.
Int -> Story a -> (Int, [(([Char], [Char]), Maybe [Char])])
walk Int
n' (b -> Story a
next b
r)
            in  (Int
n'', [(([Char], [Char]), Maybe [Char])]
rows [(([Char], [Char]), Maybe [Char])]
-> [(([Char], [Char]), Maybe [Char])]
-> [(([Char], [Char]), Maybe [Char])]
forall a. Semigroup a => a -> a -> a
<> [(([Char], [Char]), Maybe [Char])]
rest)

    walkClauses
        :: String
        -> Int
        -> Program (Clause thm CliI) a
        -> (Int, [((String, String), Maybe String)], a)
    walkClauses :: forall {k} (thm :: k) a.
[Char]
-> Int
-> Program (Clause thm CliI) a
-> (Int, [(([Char], [Char]), Maybe [Char])], a)
walkClauses [Char]
name Int
n Program (Clause thm CliI) a
program = case Program (Clause thm CliI) a -> ProgramView (Clause thm CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Program (Clause thm CliI) a
program of
        Return a
a -> (Int
n, [], a
a)
        Clause [Char]
title LeanCheck CliI thm b
leanCheck Story CliI b
body :>>= b -> Program (Clause thm CliI) a
next ->
            let (Int
n1, b
obs, Maybe [Char]
retired) = Int -> Story CliI b -> (Int, b, Maybe [Char])
forall a. Int -> Story a -> (Int, a, Maybe [Char])
retiring Int
n Story CliI b
body
                (Int
n2, ()
_) = Int -> Story CliI () -> (Int, ())
forall a. Int -> Story a -> (Int, a)
run Int
n1 (LeanCheck CliI thm b -> b -> Story CliI ()
forall {k} (act :: * -> *) (thm :: k) obs.
LeanCheck act thm obs -> obs -> Story act ()
checkAction LeanCheck CliI thm b
leanCheck b
obs)
                (Int
n3, [(([Char], [Char]), Maybe [Char])]
rows, a
a) = [Char]
-> Int
-> Program (Clause thm CliI) a
-> (Int, [(([Char], [Char]), Maybe [Char])], a)
forall {k} (thm :: k) a.
[Char]
-> Int
-> Program (Clause thm CliI) a
-> (Int, [(([Char], [Char]), Maybe [Char])], a)
walkClauses [Char]
name Int
n2 (b -> Program (Clause thm CliI) a
next b
obs)
            in  (Int
n3, (([Char]
name, [Char]
title), Maybe [Char]
retired) (([Char], [Char]), Maybe [Char])
-> [(([Char], [Char]), Maybe [Char])]
-> [(([Char], [Char]), Maybe [Char])]
forall a. a -> [a] -> [a]
: [(([Char], [Char]), Maybe [Char])]
rows, a
a)

    run :: Int -> Story a -> (Int, a)
    run :: forall a. Int -> Story a -> (Int, a)
run Int
n Story a
program = let (Int
n', a
a, Maybe [Char]
_) = Int -> Story a -> (Int, a, Maybe [Char])
forall a. Int -> Story a -> (Int, a, Maybe [Char])
retiring Int
n Story a
program in (Int
n', a
a)

    -- A clause body, with the reason it retires its promise, if it does.
    retiring :: Int -> Story a -> (Int, a, Maybe String)
    retiring :: forall a. Int -> Story a -> (Int, a, Maybe [Char])
retiring Int
n Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
a -> (Int
n, a
a, Maybe [Char]
forall a. Maybe a
Nothing)
        Action (Retire [Char]
why) :>>= b -> Story a
next ->
            let (Int
n', a
a, Maybe [Char]
_) = Int -> Story a -> (Int, a, Maybe [Char])
forall a. Int -> Story a -> (Int, a, Maybe [Char])
retiring Int
n (b -> Story a
next ()) in (Int
n', a
a, [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
why)
        Action CliI b
i :>>= b -> Story a
next -> let (Int
n', b
r) = Int -> CliI b -> (Int, b)
forall a. Int -> CliI a -> (Int, a)
placeholder Int
n CliI b
i in Int -> Story a -> (Int, a, Maybe [Char])
forall a. Int -> Story a -> (Int, a, Maybe [Char])
retiring Int
n' (b -> Story a
next b
r)
        Theorem Theorem thm
_ TheoremStory thm CliI b
_ :>>= b -> Story a
_ -> [Char] -> (Int, a, Maybe [Char])
forall a. HasCallStack => [Char] -> a
error [Char]
"outline: a statement nested inside a clause"

    placeholder :: Int -> CliI a -> (Int, a)
    placeholder :: forall a. Int -> CliI a -> (Int, a)
placeholder Int
n CliI a
i = case CliI a
i of
        Require Requirement
_ [Receipt]
_ -> (Int
n, ())
        Retire [Char]
_ -> (Int
n, ())
        Run{} -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
"")
        RunByToken{} -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
"")
        Book{} -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
"")
        FoldUnevaluated{} -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
"")
        Observe{} -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
"")
        Craft{} -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
"")
        Provoke{} -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
"")
        Reclaim{} -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
"")
        ReadIndexer{} -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
"")

{- | Refuse a story before it runs: every statement it binds must be one of
'statementBindings' and told once, every clause title distinct within its
statement, and every refusal paired with an accepting clause in the same
telling.
-}
validateControls :: Story () -> Either String ()
validateControls :: Story CliI () -> Either [Char] ()
validateControls Story CliI ()
story = do
    let rows :: [([Char], [Char])]
rows = Story CliI () -> [([Char], [Char])]
outline Story CliI ()
story
        statements :: [[Char]]
statements = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ((([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst [([Char], [Char])]
rows)
        told :: [[Char]]
told = Story CliI () -> [[Char]]
tellings Story CliI ()
story
    Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
told Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub [[Char]]
told)) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left
            [Char]
"a statement is told more than once; each telling needs its own control"
    [[Char]] -> ([Char] -> Either [Char] ()) -> Either [Char] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
statements (([Char] -> Either [Char] ()) -> Either [Char] ())
-> ([Char] -> Either [Char] ()) -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s -> do
        Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            ( [Char]
s
                [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (BoundObligation -> [Char]) -> [BoundObligation] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
                    BoundObligation -> [Char]
boName
                    ([BoundObligation]
statementBindings [BoundObligation] -> [BoundObligation] -> [BoundObligation]
forall a. Semigroup a => a -> a -> a
<> [BoundObligation]
obligationBindings [BoundObligation] -> [BoundObligation] -> [BoundObligation]
forall a. Semigroup a => a -> a -> a
<> [BoundObligation]
clientPolicyBindings)
            )
            (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
s [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not a statement or obligation this domain binds")
        let titles :: [[Char]]
titles = [[Char]
t | ([Char]
s', [Char]
t) <- [([Char], [Char])]
rows, [Char]
s' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
s]
        Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
titles Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub [[Char]]
titles)) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
s [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" repeats a clause")
        Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
            ( ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text
"is refused" Text -> Text -> Bool
`T.isInfixOf`) (Text -> Bool) -> ([Char] -> Text) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack) [[Char]]
titles
                Bool -> Bool -> Bool
&& Bool -> Bool
not (([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text
"is accepted" Text -> Text -> Bool
`T.isSuffixOf`) (Text -> Bool) -> ([Char] -> Text) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack) [[Char]]
titles)
            )
            (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
s [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" has a refusal without an accepting control")
    let (Int
loose, [([Char], [([Char], Bool)])]
shapes) = Story CliI () -> (Int, [([Char], [([Char], Bool)])])
shape Story CliI ()
story
    Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
loose Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left
            ( Int -> [Char]
forall a. Show a => a -> [Char]
show Int
loose
                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" actions run outside any clause; every receipt must feed a verdict"
            )
    [([Char], [([Char], Bool)])]
-> (([Char], [([Char], Bool)]) -> Either [Char] ())
-> Either [Char] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [([Char], [([Char], Bool)])]
shapes ((([Char], [([Char], Bool)]) -> Either [Char] ())
 -> Either [Char] ())
-> (([Char], [([Char], Bool)]) -> Either [Char] ())
-> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ \([Char]
s, [([Char], Bool)]
clauseShapes) ->
        Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
            ( (([Char], Bool) -> Bool) -> [([Char], Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text
"is refused" Text -> Text -> Bool
`T.isInfixOf`) (Text -> Bool)
-> (([Char], Bool) -> Text) -> ([Char], Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text)
-> (([Char], Bool) -> [Char]) -> ([Char], Bool) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Bool) -> [Char]
forall a b. (a, b) -> a
fst) [([Char], Bool)]
clauseShapes
                Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool -> (([Char], Bool) -> Bool) -> Maybe ([Char], Bool) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ([Char], Bool) -> Bool
forall a b. (a, b) -> b
snd ([([Char], Bool)] -> Maybe ([Char], Bool)
forall a. [a] -> Maybe a
listToMaybe [([Char], Bool)]
clauseShapes))
            )
            (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
s [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" makes a refusal claim without opening on its premise")
    () -> Either [Char] ()
forall a b. b -> Either a b
Right ()

-- ---------------------------------------------------------
-- Rendering
-- ---------------------------------------------------------

-- | The ordinary commands a story runs, in order, as the steps name them (#528).
storyCommands :: Story () -> [Command]
storyCommands :: Story CliI () -> [Command]
storyCommands = Story CliI () -> [Command]
forall a. Story a -> [Command]
go
  where
    go :: Story a -> [Command]
    go :: forall a. Story a -> [Command]
go Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
_ -> []
        Action CliI b
i :>>= b -> Story a
next -> CliI b -> [Command]
forall a. CliI a -> [Command]
commandOf CliI b
i [Command] -> [Command] -> [Command]
forall a. Semigroup a => a -> a -> a
<> Story a -> [Command]
forall a. Story a -> [Command]
go (b -> Story a
next (CliI b -> b
forall a. CliI a -> a
blank CliI b
i))
        Theorem Theorem thm
_ TheoremStory thm CliI b
body :>>= b -> Story a
next -> Program (Clause thm CliI) b -> (b -> Story a) -> [Command]
forall {k} (thm :: k) b a.
Program (Clause thm CliI) b -> (b -> Story a) -> [Command]
inClauses (TheoremStory thm CliI b -> Program (Clause thm CliI) b
forall {k} (thm :: k) (act :: * -> *) res.
TheoremStory thm act res -> Program (Clause thm act) res
clauses TheoremStory thm CliI b
body) b -> Story a
next
    inClauses
        :: Program (Clause thm CliI) b -> (b -> Story a) -> [Command]
    inClauses :: forall {k} (thm :: k) b a.
Program (Clause thm CliI) b -> (b -> Story a) -> [Command]
inClauses Program (Clause thm CliI) b
p b -> Story a
k = case Program (Clause thm CliI) b -> ProgramView (Clause thm CliI) b
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Program (Clause thm CliI) b
p of
        Return b
b -> Story a -> [Command]
forall a. Story a -> [Command]
go (b -> Story a
k b
b)
        Clause [Char]
_ LeanCheck CliI thm b
leanCheck Story CliI b
body :>>= b -> Program (Clause thm CliI) b
next ->
            let obs :: b
obs = Story CliI b -> b
forall a. Story a -> a
resultOf Story CliI b
body
            in  Story CliI b -> [Command]
forall a. Story a -> [Command]
go Story CliI b
body [Command] -> [Command] -> [Command]
forall a. Semigroup a => a -> a -> a
<> Story CliI () -> [Command]
forall a. Story a -> [Command]
go (LeanCheck CliI thm b -> b -> Story CliI ()
forall {k} (act :: * -> *) (thm :: k) obs.
LeanCheck act thm obs -> obs -> Story act ()
checkAction LeanCheck CliI thm b
leanCheck b
obs) [Command] -> [Command] -> [Command]
forall a. Semigroup a => a -> a -> a
<> Program (Clause thm CliI) b -> (b -> Story a) -> [Command]
forall {k} (thm :: k) b a.
Program (Clause thm CliI) b -> (b -> Story a) -> [Command]
inClauses (b -> Program (Clause thm CliI) b
next b
obs) b -> Story a
k
    commandOf :: CliI a -> [Command]
    commandOf :: forall a. CliI a -> [Command]
commandOf CliI a
i = case CliI a
i of
        Run Command
c Target
_ [Char]
_ -> [Command
c]
        RunByToken Target
_ Target
_ Command
c [Char]
_ -> [Command
c]
        Provoke Provocation
p Target
_ [Char]
_ -> [Provocation -> Command
provocationCommand Provocation
p]
        CliI a
_ -> []
    resultOf :: Story a -> a
    resultOf :: forall a. Story a -> a
resultOf Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
a -> a
a
        Action CliI b
i :>>= b -> Story a
next -> Story a -> a
forall a. Story a -> a
resultOf (b -> Story a
next (CliI b -> b
forall a. CliI a -> a
blank CliI b
i))
        Theorem Theorem thm
_ TheoremStory thm CliI b
_ :>>= b -> Story a
_ -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"storyCommands: a statement nested inside a clause"
    blank :: CliI a -> a
    blank :: forall a. CliI a -> a
blank CliI a
i = case CliI a
i of
        Require Requirement
_ [Receipt]
_ -> ()
        Retire [Char]
_ -> ()
        Run{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        RunByToken{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Book{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        FoldUnevaluated{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Observe{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Craft{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Provoke{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Reclaim{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        ReadIndexer{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""

-- | The distinct executables a story's steps run, in first-seen order, from the same source that names each step (#528).
storyExecutables :: Story () -> [String]
storyExecutables :: Story CliI () -> [[Char]]
storyExecutables Story CliI ()
story = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ((Command -> [Char]) -> [Command] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Command -> [Char]
commandExecutable (Story CliI () -> [Command]
storyCommands Story CliI ()
story))

-- | The introduction's executable phrase, derived from the steps the story actually has (#528).
introductionExecutablePhrase :: Story () -> String
introductionExecutablePhrase :: Story CliI () -> [Char]
introductionExecutablePhrase Story CliI ()
story = case Story CliI () -> [[Char]]
storyExecutables Story CliI ()
story of
    [] -> [Char]
"the ordinary commands"
    [[Char]]
exes ->
        [Char]
"the ordinary "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" and " (ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
e -> [Char]
"`" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
e [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`") [[Char]]
exes)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" commands"

{- | The section a reader sees: each statement, what was done, the verdict
of each clause as the receipts give it, and the approved matrix of cases
with each one's coverage computed from those verdicts. Uncovered clauses
and cases are listed, with the reason, beside the rest.
-}
renderControls :: [ClauseResult] -> Story () -> String
renderControls :: [ClauseResult] -> Story CliI () -> [Char]
renderControls [ClauseResult]
results Story CliI ()
story =
    [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
        [ [Char]
"## The ordinary CLI and the application's boundary, judged from receipts"
        , [Char]
""
        , [Char]
"Alice's story runs through "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Story CliI () -> [Char]
introductionExecutablePhrase Story CliI ()
story
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", and each claim about it is checked against the receipts those commands print: the registry create booted, the holding insert delivered, the payloads the updates wrote with the root unmoved, and the deposit terminate released."
        , [Char]
""
        , [Char]
"The early refusals are the client's: "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Story CliI () -> [Char]
introductionExecutablePhrase Story CliI ()
story
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" refuse a booking the key's current entry rules out before anything is signed, naming the key and the client policy, with nothing submitted and no request left pending."
        , [Char]
""
        , [Char]
"The chain's own refusals are the node's. Each refused transaction is submitted without evaluating its scripts locally, so the node judges it, and each refusal names the script that failed: the registry's state validator for a booking of a key the registry already holds, and the applied open-datum script for a tampered update or a release outside any fold. Every refusal sits beside an accepting control built the same way, and readbacks before and after show that nothing moved. The node does not report the model's reason for a refusal, and no reason is claimed as observed."
        , [Char]
""
        , [Char]
"The last tellings are the client's own obligations, not model statements: rows of the CLI's specification (`"
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
cliSpecification
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`), each bound by the SHA-256 of its line. They cover what the commands do when another process holds the registry's lock, a saved file is changed or missing, the node is absent or stops, or a command is killed after the node accepted its transaction. Each claim is computed from the command's printed receipt and the registry's journal, both read back from the run's files."
        , [Char]
""
        , [Char]
"### What was done"
        , [Char]
""
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Story CliI () -> [[Char]]
steps Story CliI ()
story
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
""
               , [Char]
"### Verdicts, computed from the receipts"
               , [Char]
""
               , [Char]
"| statement | clause | verdict |"
               , [Char]
"|---|---|---|"
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"| `"
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ClauseResult -> [Char]
crStatement ClauseResult
r
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` | "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ClauseResult -> [Char]
crTitle ClauseResult
r
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" | "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ClauseStatus -> [Char]
verdictText (ClauseResult -> ClauseStatus
crStatus ClauseResult
r)
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" |"
               | ClauseResult
r <- [ClauseResult]
results
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
""
               , [Char]
summary
               , [Char]
""
               , [Char]
"### The approved cases and what covers each"
               , [Char]
""
               , [Char]
"A case is covered when the clause that exercises it holds on the receipts above. Cases the live run does not reach are listed as uncovered with the reason; the Aiken suite's own tests of them are separate evidence and are not counted here."
               , [Char]
""
               , [Char]
"| case | statement | coverage |"
               , [Char]
"|---|---|---|"
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"| " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
name [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" | " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
stmt [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" | " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Coverage -> [Char]
coverage Coverage
cov [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" |"
               | ([Char]
name, [Char]
stmt, Coverage
cov) <- [([Char], [Char], Coverage)]
approvedCases
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
""
               , [Char]
caseSummary
               , [Char]
""
               , [Char]
"### Replaced clauses"
               , [Char]
""
               , [Char]
"A clause a ruling replaced is listed here with the clause that replaces it, so a verdict published under the old wording can be read against the new one."
               , [Char]
""
               ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"- Under `"
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
obligation
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`, \""
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
old
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\" is replaced by \""
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
new
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\": "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
why
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"."
               | ([Char]
obligation, [Char]
old, [Char]
new, [Char]
why) <- [([Char], [Char], [Char], [Char])]
replacedClauses
               ]
  where
    verdictText :: ClauseStatus -> [Char]
verdictText ClauseStatus
s = case ClauseStatus
s of
        ClauseStatus
Held -> [Char]
"holds"
        NotHeld [[Char]]
why -> [Char]
"does not hold: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"; " [[Char]]
why
        Uncovered [Char]
why -> [Char]
"uncovered: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
why
        Retired [Char]
why -> [Char]
why
    judged :: [ClauseResult]
judged = [ClauseResult]
results
    uncovered :: Int
uncovered = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | ClauseResult [Char]
_ [Char]
_ (Uncovered [Char]
_) <- [ClauseResult]
judged]
    notHeld :: Int
notHeld = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | ClauseResult [Char]
_ [Char]
_ (NotHeld [[Char]]
_) <- [ClauseResult]
judged]
    retired :: Int
retired = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | ClauseResult [Char]
_ [Char]
_ (Retired [Char]
_) <- [ClauseResult]
judged]
    summary :: [Char]
summary =
        Int -> [Char]
forall a. Show a => a -> [Char]
show ([ClauseResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClauseResult]
judged Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
uncovered Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
notHeld Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
retired)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" of "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([ClauseResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClauseResult]
judged)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" clauses hold; "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
notHeld
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" do not; "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
uncovered
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" are uncovered"
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if Int
retired Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then [Char]
"; " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
retired [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" are retired." else [Char]
".")
    coverage :: Coverage -> [Char]
coverage Coverage
cov = case Coverage
cov of
        NotLive [Char]
why -> [Char]
"uncovered: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
why
        ByClause [Char]
stmt [Char]
title ->
            case [ ClauseResult -> ClauseStatus
crStatus ClauseResult
r
                 | ClauseResult
r <- [ClauseResult]
results
                 , ClauseResult -> [Char]
crStatement ClauseResult
r [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== ShowS
qualified [Char]
stmt
                 , ClauseResult -> [Char]
crTitle ClauseResult
r [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
title
                 ] of
                [ClauseStatus
Held] -> [Char]
"covered: the clause holds"
                [Uncovered [Char]
why] -> [Char]
"uncovered: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
why
                [Retired [Char]
why] -> [Char]
why
                [NotHeld [[Char]]
why] -> [Char]
"not covered: the clause does not hold: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"; " [[Char]]
why
                [ClauseStatus]
_ -> [Char]
"uncovered: its clause did not run"
        ByObligations [([Char], [[Char]])]
rows ->
            let statusOf :: ([Char], [Char]) -> [ClauseStatus]
statusOf ([Char]
row, [Char]
title) =
                    [ ClauseResult -> ClauseStatus
crStatus ClauseResult
r
                    | ClauseResult
r <- [ClauseResult]
results
                    , ClauseResult -> [Char]
crStatement ClauseResult
r [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
row
                    , ClauseResult -> [Char]
crTitle ClauseResult
r [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
title
                    ]
                wanted :: [([Char], [Char])]
wanted = [([Char]
row, [Char]
title) | ([Char]
row, [[Char]]
titles) <- [([Char], [[Char]])]
rows, [Char]
title <- [[Char]]
titles]
            in  case (([Char], [Char]) -> [ClauseStatus])
-> [([Char], [Char])] -> [ClauseStatus]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char], [Char]) -> [ClauseStatus]
statusOf [([Char], [Char])]
wanted of
                    [ClauseStatus]
ss
                        | [ClauseStatus] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClauseStatus]
ss Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [([Char], [Char])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Char], [Char])]
wanted ->
                            [Char]
"uncovered: a clause of it did not run"
                        | Bool
otherwise ->
                            -- The live obligations decide the case; a retired
                            -- promise among them is named beside, never
                            -- standing for them.
                            let live :: [ClauseStatus]
live = (ClauseStatus -> Bool) -> [ClauseStatus] -> [ClauseStatus]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ClauseStatus -> Bool) -> ClauseStatus -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClauseStatus -> Bool
isRetired) [ClauseStatus]
ss
                                retirement :: [[Char]]
retirement = [[Char]
why | Retired [Char]
why <- [ClauseStatus]
ss]
                                beside :: [Char]
beside = case [[Char]]
retirement of
                                    [Char]
why : [[Char]]
_ -> [Char]
"; " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
why
                                    [] -> [Char]
""
                            in  case [ClauseStatus]
live of
                                    [] -> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take Int
1 [[Char]]
retirement)
                                    [ClauseStatus]
_
                                        | (ClauseStatus -> Bool) -> [ClauseStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ClauseStatus -> ClauseStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ClauseStatus
Held) [ClauseStatus]
live ->
                                            [Char]
"covered: the clause holds" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
beside
                                        | (Uncovered [Char]
why : [ClauseStatus]
_) <- (ClauseStatus -> Bool) -> [ClauseStatus] -> [ClauseStatus]
forall a. (a -> Bool) -> [a] -> [a]
filter (ClauseStatus -> ClauseStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= ClauseStatus
Held) [ClauseStatus]
live ->
                                            [Char]
"uncovered: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
why [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
beside
                                        | (NotHeld [[Char]]
why : [ClauseStatus]
_) <- (ClauseStatus -> Bool) -> [ClauseStatus] -> [ClauseStatus]
forall a. (a -> Bool) -> [a] -> [a]
filter (ClauseStatus -> ClauseStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= ClauseStatus
Held) [ClauseStatus]
live ->
                                            [Char]
"not covered: a clause does not hold: "
                                                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"; " [[Char]]
why
                                                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
beside
                                        | Bool
otherwise ->
                                            [Char]
"uncovered: a clause of it did not run" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
beside
    covered :: Int
covered =
        [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
            [ ()
            | ([Char]
_, [Char]
_, Coverage
cov) <- [([Char], [Char], Coverage)]
approvedCases
            , [Char]
"covered: the clause holds" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Coverage -> [Char]
coverage Coverage
cov
            ]
    caseSummary :: [Char]
caseSummary =
        Int -> [Char]
forall a. Show a => a -> [Char]
show Int
covered
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" of "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([([Char], [Char], Coverage)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Char], [Char], Coverage)]
approvedCases)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" approved cases are covered live; "
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([([Char], [Char], Coverage)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Char], [Char], Coverage)]
approvedCases Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
covered)
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" are not."

-- | How an approved case is exercised: by a named clause, or not live.
data Coverage
    = ByClause String String
    | -- | A row of the CLI's specification, covered when every clause named holds
      ByObligations [(String, [String])]
    | NotLive String

qualified :: String -> String
qualified :: ShowS
qualified = ([Char]
"OpenDatumApplication.Statements." [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>)

{- | Clauses a ruling replaced: the obligation, the clause as it read, the
clause that replaces it, and why. Printed at the end of the verdict
section, so the old wording stays visible beside the new one.
-}
replacedClauses :: [(String, String, String, String)]
replacedClauses :: [([Char], [Char], [Char], [Char])]
replacedClauses =
    [
        ( [Char]
"INV299-AUTHENTICATED"
        , [Char]
"inspect with the saved proof material moved aside prints no leaf"
        , [Char]
"inspect with the public history it needs withheld prints no leaf and names HistoryIncomplete"
        , [Char]
"inspect now reads no saved proof material; it rebuilds a root-checked trie from public history, so the witness withholds that history instead, while the obligation, that inspect never prints a leaf it cannot authenticate, is unchanged (operator ruling of 7 October 2026). Named limit: history is withheld by a test forwarder answering empty; a provider that errors instead produces a client refusal, which this witness does not cover"
        )
    ,
        ( [Char]
"R299-05"
        , [Char]
"a create from another wallet on its own live seed, held before the lock while a first create completes, is refused because the registry exists"
        , [Char]
"the same wallet starts create on the same seed twice; the second is held before the lock while the first completes, and is refused because the registry exists"
        , [Char]
"per-wallet state makes the cross-wallet collision impossible: each wallet boots only in its own partition, so a second create for one target can only come from the same wallet on the same seed (desk ruling of 9 October 2026)"
        )
    ]

{- | The approved matrix of controls for the ordinary CLI and the
open-datum application, each with the statement it bears on (or the
client safety it checks) and the clause that exercises it live.
-}
approvedCases :: [(String, String, Coverage)]
approvedCases :: [([Char], [Char], Coverage)]
approvedCases =
    [
        ( [Char]
"a second insertion of an Active key"
        , [Char]
"`duplicate_refused_by_registry`"
        , [Char] -> [Char] -> Coverage
ByClause
            [Char]
"duplicate_refused_by_registry"
            [Char]
"the ordinary insert of the Active key is refused before signing, naming the key already registered"
        )
    ,
        ( [Char]
"an insertion of a Terminal key"
        , [Char]
"`resurrection_refused_by_registry`"
        , [Char] -> [Char] -> Coverage
ByClause
            [Char]
"resurrection_refused_by_registry"
            [Char]
"the ordinary insert of the Terminal key is refused before signing, naming the key already retired"
        )
    ,
        ( [Char]
"an Active key booked through the permissive builders, folded, is refused"
        , [Char]
"`duplicate_refused_by_registry`"
        , [Char] -> [Char] -> Coverage
ByClause [Char]
"duplicate_refused_by_registry" [Char]
registryRefusal
        )
    ,
        ( [Char]
"a Terminal key booked through the permissive builders, folded, is refused"
        , [Char]
"`resurrection_refused_by_registry`"
        , [Char] -> [Char] -> Coverage
ByClause [Char]
"resurrection_refused_by_registry" [Char]
registryRefusal
        )
    ,
        ( [Char]
"an update of an unknown key"
        , [Char]
"`client-policy-booking-refused`, no model statement and no specification row"
        , [([Char], [[Char]])] -> Coverage
ByObligations
            [
                ( [Char]
"client-policy-booking-refused"
                ,
                    [ [Char]
"Bob's update of the unknown key is refused before signing, naming the key not registered"
                    ]
                )
            ]
        )
    ,
        ( [Char]
"an update of a Terminal key"
        , [Char]
"`client-policy-booking-refused`, no model statement and no specification row"
        , [([Char], [[Char]])] -> Coverage
ByObligations
            [
                ( [Char]
"client-policy-booking-refused"
                ,
                    [ [Char]
"Bob's update of the Terminal key is refused before signing, naming the key already retired"
                    ]
                )
            ]
        )
    ,
        ( [Char]
"an update not signed by the controller"
        , [Char]
"`update_requires_controller`"
        , [Char] -> [Char] -> Coverage
ByClause
            [Char]
"update_requires_controller"
            [Char]
"the same update, requiring another wallet's signature instead of the controller's, is refused by the application"
        )
    ]
        [([Char], [Char], Coverage)]
-> [([Char], [Char], Coverage)] -> [([Char], [Char], Coverage)]
forall a. Semigroup a => a -> a -> a
<> [ ( Crafted -> [Char]
craftedPhrase Crafted
c
             , [Char]
"`update_preserves_custody`"
             , [Char] -> [Char] -> Coverage
ByClause
                [Char]
"update_preserves_custody"
                (Crafted -> [Char]
craftedPhrase Crafted
c [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is refused by the application")
             )
           | Crafted
c <-
                [ Crafted
UpdateOtherController
                , Crafted
UpdateDepositTampered
                , Crafted
UpdateEscaped
                , Crafted
UpdateTokenLeft
                , Crafted
UpdateShortDeposit
                , Crafted
UpdateWithoutDatum
                , Crafted
UpdateAddedAsset
                ]
           ]
        [([Char], [Char], Coverage)]
-> [([Char], [Char], Coverage)] -> [([Char], [Char], Coverage)]
forall a. Semigroup a => a -> a -> a
<> [
               ( [Char]
"an update whose continuation duplicates the token's carrier"
               , [Char]
"`update_preserves_custody`"
               , [Char] -> Coverage
NotLive
                    [Char]
"the live suite runs no transaction for it: with one active token per Active key and no active mint in an update, the ledger's conservation of value keeps two carriers from forming, so the application never sees the case. Not tested live; recorded by operator ruling in `specs/299-singular-cli/ruling-duplicate-carrier.md`, which states the argument's limits; the model's and the validator's own tests of it are kept"
               )
           ,
               ( [Char]
"a release of the live holding outside any fold"
               , [Char]
"`only_fold_releases`"
               , [Char] -> [Char] -> Coverage
ByClause
                    [Char]
"only_fold_releases"
                    [Char]
"a release of the live holding outside any fold is refused by the application"
               )
           ]
        [([Char], [Char], Coverage)]
-> [([Char], [Char], Coverage)] -> [([Char], [Char], Coverage)]
forall a. Semigroup a => a -> a -> a
<> [ ( Crafted -> [Char]
craftedPhrase Crafted
c
             , [Char]
"`" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
stmt [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"
             , [Char] -> [Char] -> Coverage
ByClause [Char]
stmt (Crafted -> [Char]
craftedPhrase Crafted
c [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is refused by the application")
             )
           | (Crafted
c, [Char]
stmt) <-
                [ (Crafted
BookingByStranger, [Char]
"bookInsert_inversion")
                , (Crafted
BookingOtherDestination, [Char]
"bookInsert_inversion")
                , (Crafted
BookingShortDeposit, [Char]
"bookInsert_inversion")
                , (Crafted
BookingNoDatum, [Char]
"bookInsert_inversion")
                , (Crafted
EnvelopeOtherStateName, [Char]
"insertion_requires_registry_identity")
                , (Crafted
EnvelopeOtherStatePolicy, [Char]
"insertion_requires_registry_identity")
                , (Crafted
EnvelopeOtherRegistry, [Char]
"insertion_requires_registry_identity")
                , (Crafted
TerminateBookingByStranger, [Char]
"bookTerminate_inversion")
                , (Crafted
ReleaseInOtherFold, [Char]
"fold_inversion")
                , (Crafted
FoldPaysShort, [Char]
"fold_settles_additively")
                ]
           ]
        [([Char], [Char], Coverage)]
-> [([Char], [Char], Coverage)] -> [([Char], [Char], Coverage)]
forall a. Semigroup a => a -> a -> a
<> [ ( [Char]
name
             , [Char]
"`fold_settles_additively`"
             , [Char] -> [Char] -> Coverage
ByClause
                [Char]
"fold_settles_additively"
                (Crafted -> [Char]
craftedPhrase Crafted
c [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is refused by the application")
             )
           | ([Char]
name, Crafted
c) <-
                [
                    ( [Char]
"a mixed fold paying one controller one lovelace short"
                    , Crafted
FoldMixedShort
                    )
                ,
                    ( [Char]
"two releases to one controller paid one lovelace short"
                    , Crafted
FoldTwoReleasesShort
                    )
                ,
                    ( [Char]
"two releases paid one floor where the sum is owed"
                    , Crafted
FoldTwoReleasesOneFloor
                    )
                ]
           ]
        [([Char], [Char], Coverage)]
-> [([Char], [Char], Coverage)] -> [([Char], [Char], Coverage)]
forall a. Semigroup a => a -> a -> a
<> [ ( [Char]
name
             , [Char]
"client obligation `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
row [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`, no model statement"
             , [([Char], [[Char]])] -> Coverage
ByObligations [([Char]
row, [[Char]]
titles)]
             )
           | ([Char]
name, [Char]
row, [[Char]]
titles) <-
                [
                    ( [Char]
"a second create racing for one seed with one wallet"
                    , [Char]
"R299-05"
                    ,
                        [ [Char]
"the same wallet starts create on the same seed twice; the second is held before the lock while the first completes, and is refused because the registry exists"
                        ]
                    )
                ,
                    ( [Char]
"a create interrupted after its first accepted submission"
                    , [Char]
"INV299-PARTIAL"
                    ,
                        [ [Char]
"a create killed once the node accepted its boot stopped there, its body kept"
                        , [Char]
"a second create of that registry is refused before submitting"
                        , [Char]
"inspect reads the incomplete create from its journal and observes its boot, printing no leaf"
                        ]
                    )
                ,
                    ( [Char]
"a node lost after an accepted submission"
                    , [Char]
"R299-05"
                    ,
                        [ [Char]
"an update held once the node accepted it, with the node stopped, ends within its bound naming its transaction"
                        ]
                    )
                ,
                    ( [Char]
"a fold killed after the node accepted it"
                    , [Char]
"INV299-PARTIAL"
                    ,
                        [ [Char]
"a terminate killed once the node accepted its fold stopped there, its body kept"
                        , [Char]
"an update of another key then reconciles the fold from the chain and proceeds, or, while the fold is not yet on chain, is refused before submitting, naming the fold and its case"
                        , [Char]
"inspect reads the key Terminal, the fold replayed at the chain root, never resubmitted and observed once across every receipt: the killed terminate's fold is accepted"
                        ]
                    )
                ,
                    ( [Char]
"the Active key read from two public indexers before its termination"
                    , [Char]
"INV300-INDEXER"
                    , (Indexer -> [Char]) -> [Indexer] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Indexer -> [Char]
indexerTitle [Indexer
forall a. Bounded a => a
minBound .. Indexer
forall a. Bounded a => a
maxBound]
                    )
                ,
                    ( [Char]
"a concurrent writer holding the target's lock"
                    , [Char]
"R299-05"
                    ,
                        [ [Char]
"an insert while another process holds the registry's lock is refused before submitting"
                        , [Char]
"the same insert, once the lock is released, is accepted"
                        ]
                    )
                ,
                    ( [Char]
"a termination of an unknown key"
                    , [Char]
"terminate-burns-active-holding"
                    ,
                        [ [Char]
"Bob's terminate of the unknown key is refused before signing, naming the key not registered"
                        ]
                    )
                ,
                    ( [Char]
"a termination of a Terminal key"
                    , [Char]
"terminate-burns-active-holding"
                    ,
                        [ [Char]
"Bob's terminate of the Terminal key is refused before signing, naming the key already retired"
                        ]
                    )
                ]
           ]
        [([Char], [Char], Coverage)]
-> [([Char], [Char], Coverage)] -> [([Char], [Char], Coverage)]
forall a. Semigroup a => a -> a -> a
<> [
               ( [Char]
"withheld public history, a changed application selector, an unavailable node"
               , [Char]
"client obligations `INV299-AUTHENTICATED`, `INV299-IDENTITY`, `INV299-READONLY`, no model statement"
               , [([Char], [[Char]])] -> Coverage
ByObligations
                    [
                        ( [Char]
"INV299-AUTHENTICATED"
                        ,
                            [ [Char]
"inspect with the public history it needs withheld prints no leaf and names HistoryIncomplete"
                            ]
                        )
                    ,
                        ( [Char]
"INV299-IDENTITY"
                        ,
                            [ [Char]
"an insert with the saved application selector changed is refused before submitting"
                            , [Char]
"the same insert, with the selector restored, is accepted"
                            ]
                        )
                    ,
                        ( [Char]
"INV299-READONLY"
                        , [[Char]
"inspect against a node socket that does not exist prints no leaf"]
                        )
                    ]
               )
           ]
  where
    registryRefusal :: [Char]
registryRefusal =
        [Char]
"that request's fold, submitted without local evaluation, is refused by the registry's state validator"

-- | The story's actions, in the description language, numbered by step.
steps :: Story () -> [String]
steps :: Story CliI () -> [[Char]]
steps Story CliI ()
story = (Int, [[Char]]) -> [[Char]]
forall a b. (a, b) -> b
snd (Int -> Story CliI () -> (Int, [[Char]])
forall a. Int -> Story a -> (Int, [[Char]])
walk Int
0 Story CliI ()
story)
  where
    walk :: Int -> Story a -> (Int, [String])
    walk :: forall a. Int -> Story a -> (Int, [[Char]])
walk Int
n Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
_ -> (Int
n, [])
        Action CliI b
i :>>= b -> Story a
next ->
            let (Int
n', b
r, Maybe [Char]
line) = Int -> CliI b -> (Int, b, Maybe [Char])
forall a. Int -> CliI a -> (Int, a, Maybe [Char])
say Int
n CliI b
i
                (Int
n'', [[Char]]
rest) = Int -> Story a -> (Int, [[Char]])
forall a. Int -> Story a -> (Int, [[Char]])
walk Int
n' (b -> Story a
next b
r)
            in  (Int
n'', [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [[Char]]
rest ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
rest) Maybe [Char]
line)
        Theorem Theorem thm
thm TheoremStory thm CliI b
body :>>= b -> Story a
next ->
            let header :: [Char]
header =
                    [Char]
"Under `" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> BoundObligation -> [Char]
boName (Theorem thm -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem thm
thm) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`:"
                (Int
n', [[Char]]
ls, b
r) = Int -> Program (Clause thm CliI) b -> (Int, [[Char]], b)
forall {k} (thm :: k) a.
Int -> Program (Clause thm CliI) a -> (Int, [[Char]], a)
walkClauses Int
n (TheoremStory thm CliI b -> Program (Clause thm CliI) b
forall {k} (thm :: k) (act :: * -> *) res.
TheoremStory thm act res -> Program (Clause thm act) res
clauses TheoremStory thm CliI b
body)
                (Int
n'', [[Char]]
rest) = Int -> Story a -> (Int, [[Char]])
forall a. Int -> Story a -> (Int, [[Char]])
walk Int
n' (b -> Story a
next b
r)
            in  (Int
n'', [Char]
header [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
ls [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
rest)

    walkClauses
        :: Int -> Program (Clause thm CliI) a -> (Int, [String], a)
    walkClauses :: forall {k} (thm :: k) a.
Int -> Program (Clause thm CliI) a -> (Int, [[Char]], a)
walkClauses Int
n Program (Clause thm CliI) a
program = case Program (Clause thm CliI) a -> ProgramView (Clause thm CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Program (Clause thm CliI) a
program of
        Return a
a -> (Int
n, [], a
a)
        Clause [Char]
_ LeanCheck CliI thm b
leanCheck Story CliI b
body :>>= b -> Program (Clause thm CliI) a
next ->
            let (Int
n1, [[Char]]
ls1, b
obs) = Int -> Story CliI b -> (Int, [[Char]], b)
forall a. Int -> Story a -> (Int, [[Char]], a)
run Int
n Story CliI b
body
                (Int
n2, [[Char]]
ls2, ()
_) = Int -> Story CliI () -> (Int, [[Char]], ())
forall a. Int -> Story a -> (Int, [[Char]], a)
run Int
n1 (LeanCheck CliI thm b -> b -> Story CliI ()
forall {k} (act :: * -> *) (thm :: k) obs.
LeanCheck act thm obs -> obs -> Story act ()
checkAction LeanCheck CliI thm b
leanCheck b
obs)
                (Int
n3, [[Char]]
ls3, a
a) = Int -> Program (Clause thm CliI) a -> (Int, [[Char]], a)
forall {k} (thm :: k) a.
Int -> Program (Clause thm CliI) a -> (Int, [[Char]], a)
walkClauses Int
n2 (b -> Program (Clause thm CliI) a
next b
obs)
            in  (Int
n3, [[Char]]
ls1 [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
ls2 [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
ls3, a
a)

    run :: Int -> Story a -> (Int, [String], a)
    run :: forall a. Int -> Story a -> (Int, [[Char]], a)
run Int
n Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
a -> (Int
n, [], a
a)
        Action CliI b
i :>>= b -> Story a
next ->
            let (Int
n', b
r, Maybe [Char]
line) = Int -> CliI b -> (Int, b, Maybe [Char])
forall a. Int -> CliI a -> (Int, a, Maybe [Char])
say Int
n CliI b
i
                (Int
n'', [[Char]]
ls, a
a) = Int -> Story a -> (Int, [[Char]], a)
forall a. Int -> Story a -> (Int, [[Char]], a)
run Int
n' (b -> Story a
next b
r)
            in  (Int
n'', [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [[Char]]
ls ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
ls) Maybe [Char]
line, a
a)
        Theorem Theorem thm
_ TheoremStory thm CliI b
_ :>>= b -> Story a
_ -> [Char] -> (Int, [[Char]], a)
forall a. HasCallStack => [Char] -> a
error [Char]
"steps: a statement nested inside a clause"

    say :: Int -> CliI a -> (Int, a, Maybe String)
    say :: forall a. Int -> CliI a -> (Int, a, Maybe [Char])
say Int
n CliI a
i = case CliI a
i of
        Require Requirement
_ [Receipt]
_ -> (Int
n, (), Maybe [Char]
forall a. Maybe a
Nothing)
        Retire [Char]
why -> (Int
n, (), [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
why)
        Run Command
c (Target [Char]
t) [Char]
k ->
            ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
""
            , [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
                ( Int -> ShowS
forall {a}. (Show a, Num a) => a -> ShowS
numbered
                    Int
n
                    ( [Char]
"Run `"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Command -> [Char]
commandInvocation Command
c
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` on **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
t
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"**"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall {t :: * -> *} {a}.
(Foldable t, IsString (t a), Semigroup (t a)) =>
t a -> t a
forKey [Char]
k
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"."
                    )
                )
            )
        RunByToken (Target [Char]
actor) (Target [Char]
registry) Command
c [Char]
k ->
            ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
""
            , [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
                ( Int -> ShowS
forall {a}. (Show a, Num a) => a -> ShowS
numbered
                    Int
n
                    ( [Char]
"Run `"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Command -> [Char]
commandInvocation Command
c
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"` from **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
actor
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"**, an empty directory, naming **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
registry
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"** only by its state token"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall {t :: * -> *} {a}.
(Foldable t, IsString (t a), Semigroup (t a)) =>
t a -> t a
forKey [Char]
k
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"."
                    )
                )
            )
        Book (Target [Char]
t) [Char]
k ->
            ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
""
            , [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
                ( Int -> ShowS
forall {a}. (Show a, Num a) => a -> ShowS
numbered
                    Int
n
                    ( [Char]
"Book an insertion of **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
k
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"** in **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
t
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"** through the application, as `insert` does, and stop before its fold."
                    )
                )
            )
        FoldUnevaluated (Target [Char]
t) [Char]
k ->
            ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
""
            , [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
                ( Int -> ShowS
forall {a}. (Show a, Num a) => a -> ShowS
numbered
                    Int
n
                    ( [Char]
"Fold that booking of **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
k
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"** in **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
t
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"**, submitted without evaluating its scripts locally."
                    )
                )
            )
        Observe (Target [Char]
t) [Char]
k ->
            ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
""
            , [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
                ( Int -> ShowS
forall {a}. (Show a, Num a) => a -> ShowS
numbered
                    Int
n
                    ( [Char]
"Read back **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
t
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"**: its root, the holding of **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
k
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"**, the pending requests and the wallet."
                    )
                )
            )
        Craft Crafted
c (Target [Char]
t) [Char]
k ->
            ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
""
            , [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
                ( Int -> ShowS
forall {a}. (Show a, Num a) => a -> ShowS
numbered
                    Int
n
                    ( [Char]
"Submit, without evaluating its scripts locally, "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Crafted -> [Char]
craftedPhrase Crafted
c
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", for **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
k
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"** in **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
t
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"**."
                    )
                )
            )
        Provoke Provocation
p (Target [Char]
t) [Char]
k ->
            ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
""
            , [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
                ( Int -> ShowS
forall {a}. (Show a, Num a) => a -> ShowS
numbered
                    Int
n
                    (Provocation -> [Char]
provocationPhrase Provocation
p [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", on **" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
t [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"**" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall {t :: * -> *} {a}.
(Foldable t, IsString (t a), Semigroup (t a)) =>
t a -> t a
forKey [Char]
k [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
".")
                )
            )
        Reclaim (Target [Char]
t) [Char]
k Receipt
_ Receipt
_ ->
            ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
""
            , [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
                ( Int -> ShowS
forall {a}. (Show a, Num a) => a -> ShowS
numbered
                    Int
n
                    ( [Char]
"Retract, as its owner and inside its retract window, the request the refused insertion left pending, for **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
k
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"** in **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
t
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"**."
                    )
                )
            )
        ReadIndexer Indexer
ix (Target [Char]
t) [Char]
k Receipt
_ ->
            ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
n Text
"" Text
"" Text
""
            , [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
                ( Int -> ShowS
forall {a}. (Show a, Num a) => a -> ShowS
numbered
                    Int
n
                    ( [Char]
"Ask "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Indexer -> [Char]
indexerName Indexer
ix
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", read only, for the Active key's token, and compare its output, datum and chain position with the fresh inspect, for **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
k
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"** in **"
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
t
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"**."
                    )
                )
            )
    numbered :: a -> ShowS
numbered a
n [Char]
s = a -> [Char]
forall a. Show a => a -> [Char]
show (a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
". " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
s
    forKey :: t a -> t a
forKey t a
k = if t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
k then t a
"" else t a
" for **" t a -> t a -> t a
forall a. Semigroup a => a -> a -> a
<> t a
k t a -> t a -> t a
forall a. Semigroup a => a -> a -> a
<> t a
"**"

-- | The statements a story tells, one entry per telling, in order.
tellings :: Story () -> [String]
tellings :: Story CliI () -> [[Char]]
tellings = Story CliI () -> [[Char]]
forall a. Story a -> [[Char]]
go
  where
    go :: Story a -> [String]
    go :: forall a. Story a -> [[Char]]
go Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
_ -> []
        Action CliI b
i :>>= b -> Story a
next -> Story a -> [[Char]]
forall a. Story a -> [[Char]]
go (b -> Story a
next (CliI b -> b
forall a. CliI a -> a
placeholderOf CliI b
i))
        Theorem Theorem thm
thm TheoremStory thm CliI b
body :>>= b -> Story a
next ->
            BoundObligation -> [Char]
boName (Theorem thm -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem thm
thm) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: Story a -> [[Char]]
forall a. Story a -> [[Char]]
go (b -> Story a
next (Program (Clause thm CliI) b -> b
forall {k} (thm :: k) a. Program (Clause thm CliI) a -> a
skip (TheoremStory thm CliI b -> Program (Clause thm CliI) b
forall {k} (thm :: k) (act :: * -> *) res.
TheoremStory thm act res -> Program (Clause thm act) res
clauses TheoremStory thm CliI b
body)))

    skip :: Program (Clause thm CliI) a -> a
    skip :: forall {k} (thm :: k) a. Program (Clause thm CliI) a -> a
skip Program (Clause thm CliI) a
program = case Program (Clause thm CliI) a -> ProgramView (Clause thm CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Program (Clause thm CliI) a
program of
        Return a
a -> a
a
        Clause [Char]
_ LeanCheck CliI thm b
_ Story CliI b
body :>>= b -> Program (Clause thm CliI) a
next -> Program (Clause thm CliI) a -> a
forall {k} (thm :: k) a. Program (Clause thm CliI) a -> a
skip (b -> Program (Clause thm CliI) a
next (Story CliI b -> b
forall a. Story a -> a
result Story CliI b
body))

    result :: Story a -> a
    result :: forall a. Story a -> a
result Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
a -> a
a
        Action CliI b
i :>>= b -> Story a
next -> Story a -> a
forall a. Story a -> a
result (b -> Story a
next (CliI b -> b
forall a. CliI a -> a
placeholderOf CliI b
i))
        Theorem Theorem thm
_ TheoremStory thm CliI b
_ :>>= b -> Story a
_ -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"tellings: a statement nested inside a clause"

    placeholderOf :: CliI a -> a
    placeholderOf :: forall a. CliI a -> a
placeholderOf CliI a
i = case CliI a
i of
        Require Requirement
_ [Receipt]
_ -> ()
        Retire [Char]
_ -> ()
        Run{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        RunByToken{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Book{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        FoldUnevaluated{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Observe{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Craft{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Provoke{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Reclaim{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        ReadIndexer{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""

-- | A crafted transaction, in the description language.
craftedPhrase :: Crafted -> String
craftedPhrase :: Crafted -> [Char]
craftedPhrase Crafted
c = case Crafted
c of
    Crafted
HonestUpdate ->
        [Char]
"the controller's own update of the live holding, with a new payload"
    Crafted
UpdateByStranger ->
        [Char]
"that update requiring another wallet's signature instead of the controller's"
    Crafted
UpdateOtherController ->
        [Char]
"an update whose continuation names another controller"
    Crafted
UpdateDepositTampered ->
        [Char]
"an update whose continuation changes the protected deposit"
    Crafted
UpdateEscaped ->
        [Char]
"an update whose continuation, token and all, goes to the controller's own address"
    Crafted
UpdateTokenLeft ->
        [Char]
"an update whose continuation stays at the application without the key's token"
    Crafted
UpdateShortDeposit ->
        [Char]
"an update whose continuation holds one lovelace less than the protected deposit"
    Crafted
UpdateWithoutDatum ->
        [Char]
"an update whose continuation carries no datum"
    Crafted
UpdateAddedAsset ->
        [Char]
"an update whose continuation also carries an asset of another policy"
    Crafted
EarlyWithdrawal ->
        [Char]
"a release of the live holding outside any fold"
    Crafted
BookingByStranger ->
        [Char]
"an insertion booking of the controller's envelope, paid and signed by another wallet"
    Crafted
BookingOtherDestination ->
        [Char]
"an insertion booking whose request names another destination"
    Crafted
BookingShortDeposit ->
        [Char]
"an insertion booking whose request deposit is one lovelace short of the protected deposit"
    Crafted
BookingNoDatum ->
        [Char]
"an insertion booking whose destination names no datum"
    Crafted
EnvelopeOtherStateName ->
        [Char]
"an insertion booking whose envelope names the registry's state policy under another token name"
    Crafted
EnvelopeOtherStatePolicy ->
        [Char]
"an insertion booking whose envelope names the registry's token name under another policy"
    Crafted
EnvelopeOtherRegistry ->
        [Char]
"an insertion booking whose envelope names another registry's state asset"
    Crafted
TerminateBooking ->
        [Char]
"the controller's own booking of the key's termination"
    Crafted
TerminateBookingByStranger ->
        [Char]
"a termination booking of the key by another wallet"
    Crafted
ReleaseInOtherFold ->
        [Char]
"a fold of another key's insertion that also releases this live holding"
    Crafted
UpdateWithoutScript ->
        [Char]
"the controller's update, submitted without the application's script"
    Crafted
FoldPaysShort ->
        [Char]
"the terminating fold, folded by another wallet, paying the controller one lovelace short"
    Crafted
FoldPaysInFull ->
        [Char]
"the same terminating fold, folded by another wallet, paying the controller in full"
    Crafted
FoldTwoReleasesShort ->
        [Char]
"one fold of two terminations for one controller, folded by another wallet, paying the controller one lovelace short of the sum"
    Crafted
FoldTwoReleasesOneFloor ->
        [Char]
"that fold paying the controller one released deposit where the sum of two is owed"
    Crafted
FoldTwoReleasesInFull ->
        [Char]
"that fold paying the controller the sum in full"
    Crafted
FoldMixedShort ->
        [Char]
"one fold of an insertion and a termination for one controller, folded by another wallet, paying the controller one lovelace short"
    Crafted
FoldMixedInFull ->
        [Char]
"that mixed fold paying the controller in full"

{- | The node's rejection, rebuilt from exactly what the receipt carries of
it — its words for a script that executed and failed, and the hashes of
the scripts that failed — and judged by the suite's own refusal discipline
('matchRefusal'): a phase-2 failure among whose failed scripts the
expected one is.
-}
attribution :: Text -> Receipt -> Either RefusalMismatch ()
attribution :: Text -> Receipt -> Either RefusalMismatch ()
attribution Text
expected Receipt
r = [Char] -> [Char] -> Either RefusalMismatch ()
matchRefusal (Text -> [Char]
T.unpack Text
expected) [Char]
rebuilt
  where
    rebuilt :: [Char]
rebuilt =
        [[Char]] -> [Char]
unwords ((Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack (Receipt -> [Text]
rcPhaseWords Receipt
r))
            [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [[Char]
" ScriptHash \"" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
h [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\"" | Text
h <- Receipt -> [Text]
rcRefusingScripts Receipt
r]

{- | Fail unless the receipt shows the expected script executed and failed —
and failed on its own terms, not because it ran out of the budget the
transaction stated for it.
-}
attributedTo :: String -> Maybe Text -> Receipt -> [String]
attributedTo :: [Char] -> Maybe Text -> Receipt -> [[Char]]
attributedTo [Char]
what Maybe Text
expected Receipt
r =
    case Maybe Text
expected of
        Maybe Text
Nothing -> [[Char]
"the " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
what [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not recorded"]
        Just Text
_
            | Text
overBudget Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Receipt -> [Text]
rcPhaseWords Receipt
r ->
                [ [Char]
"a script ran out of the budget the transaction stated for it, so its failure is not a refusal"
                ]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
submitted Receipt
r
        Just Text
h -> case Text -> Receipt -> Either RefusalMismatch ()
attribution Text
h Receipt
r of
            Right () -> []
            Left (NotPhase2 [Char]
_) ->
                [ [Char]
"the node rejected it before any script ran, so no script refused it"
                ]
            Left (MarkerAbsent [Char]
_ [Char]
_) ->
                [ [Char]
"the scripts that failed do not include the "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
what
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
h
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"; they are "
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> [Text]
rcRefusingScripts Receipt
r)
                ]
        [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
submitted Receipt
r

-- | Fail unless the retained body and rejection were read back and bind.
submitted :: Receipt -> [String]
submitted :: Receipt -> [[Char]]
submitted Receipt
r = case Receipt -> Maybe Text
rcTxId Receipt
r of
    Maybe Text
Nothing -> [[Char]
"no transaction id is recorded"]
    Just Text
_ -> Receipt -> [[Char]]
admitted Receipt
r

{- | Fail unless admission read the retained body and rejection back and
found nothing wrong: the body decodes to the receipt's transaction, the
rejection is the digested bytes, and its words and failed scripts are the
ones the verdict uses.
-}
admitted :: Receipt -> [String]
admitted :: Receipt -> [[Char]]
admitted Receipt
r = case Receipt -> Maybe [Text]
rcAdmission Receipt
r of
    Maybe [Text]
Nothing ->
        [ [Char]
"the retained body and rejection were not read back, so the receipt is not admitted"
        ]
    Just [Text]
problems -> (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
problems

{- | The node's words for a script that executed and failed, and the
hashes of the scripts that failed, as they occur in its rejection text.
-}
rejectionEvidence :: String -> ([Text], [Text])
rejectionEvidence :: [Char] -> ([Text], [Text])
rejectionEvidence [Char]
text =
    ( [[Char] -> Text
T.pack [Char]
w | [Char]
w <- [[Char]
"PlutusFailure", [Char]
"CekError"], [Char]
w [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
text]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
overBudget | [Char]
"overspending the budget" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
text]
    , ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack ([Char] -> [[Char]]
refusalScriptHashes [Char]
text)
    )

-- | The word recorded when a script failed by exhausting its stated budget.
overBudget :: Text
overBudget :: Text
overBudget = Text
"OverBudget"

-- | A key label as the lowercase hex of its bytes, as the commands print keys.
hexLabel :: String -> Text
hexLabel :: [Char] -> Text
hexLabel = [Char] -> Text
T.pack ([Char] -> Text) -> ShowS -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> [Char]) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%02x" (Int -> [Char]) -> (Char -> Int) -> Char -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord)

-- | The requirements whose failure leaves the rest of a telling unfounded.
premises :: [Requirement]
premises :: [Requirement]
premises = [Requirement
Established, Requirement
ReachedActive, Requirement
ReachedTerminal]

-- | Fail unless every receipt of a premise is of one registry.
oneRegistry :: [Receipt] -> [String]
oneRegistry :: [Receipt] -> [[Char]]
oneRegistry [Receipt]
rs =
    [ [Char]
"the premise's receipts are of different registries"
    | [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ((Receipt -> Text) -> [Receipt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Receipt -> Text
rcTarget [Receipt]
rs)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
    ]

-- | Fail unless the receipts reach the key at the given leaf.
reachedLeaf :: Text -> [Receipt] -> [String]
reachedLeaf :: Text -> [Receipt] -> [[Char]]
reachedLeaf Text
leaf [Receipt]
rs = case [Receipt] -> [Receipt]
forall a. [a] -> [a]
reverse [Receipt]
rs of
    [] -> [[Char]
"the premise has no receipts"]
    (Receipt
reading : [Receipt]
commands) ->
        (Receipt -> [[Char]]) -> [Receipt] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            (\Receipt
c -> [Char] -> Receipt -> [[Char]]
succeeded ([Char]
"the " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Receipt -> Text
rcAction Receipt
c)) Receipt
c)
            [Receipt]
commands
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Receipt] -> [[Char]]
oneRegistry [Receipt]
rs
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> Receipt -> [[Char]]
readsLeaf Receipt
reading
  where
    readsLeaf :: Receipt -> [[Char]]
readsLeaf Receipt
r
        | Text -> Bool
T.null (Receipt -> Text
rcKey Receipt
r) = [[Char]
"the premise's reading names no key"]
        | Receipt -> Text
rcAction Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"run inspect" =
            [Char] -> Receipt -> [[Char]]
succeeded [Char]
"the inspect" Receipt
r
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is [Char]
"the key's leaf" (Text -> Value
Aeson.String Text
leaf) ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"leaf"] Receipt
r)
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Value -> Maybe Value -> [[Char]]
is
                    [Char]
"the key inspected"
                    (Text -> Value
Aeson.String ([Char] -> Text
hexLabel (Text -> [Char]
T.unpack (Receipt -> Text
rcKey Receipt
r))))
                    ([Either Text Int] -> Receipt -> Maybe Value
at [Text -> Either Text Int
field Text
"key"] Receipt
r)
        | Receipt -> Text
rcAction Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"observe" =
            [ [Char]
"the readback's outcome is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show (Receipt -> Text
rcOutcome Receipt
r) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not observed"
            | Receipt -> Text
rcOutcome Receipt
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"observed"
            ]
                [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> case Observation -> Maybe Text
obLeaf (Observation -> Maybe Text) -> Maybe Observation -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Receipt -> Maybe Observation
rcObservation Receipt
r of
                    Just Text
l
                        | Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
leaf -> []
                        | Bool
otherwise ->
                            [ [Char]
"the key's leaf, authenticated against the chain's root, is "
                                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
l
                                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not "
                                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
leaf
                            ]
                    Maybe Text
Nothing ->
                        [ [Char]
"public replay does not authenticate the key's leaf at the chain's root"
                        ]
        | Bool
otherwise =
            [ [Char]
"the premise ends in "
                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Receipt -> Text
rcAction Receipt
r)
                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", not a reading of the key"
            ]

-- | The premise that the held key still reads Active, from a fresh inspect.
stillActive
    :: Theorem thm -> Target -> TheoremStory thm CliI [Receipt]
stillActive :: forall {k} (thm :: k).
Theorem thm -> Target -> TheoremStory thm CliI [Receipt]
stillActive Theorem thm
thm Target
target =
    Theorem thm
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
forall {k} (thm :: k).
Theorem thm
-> [Char]
-> Requirement
-> Story [Receipt]
-> TheoremStory thm CliI [Receipt]
premiseClause
        Theorem thm
thm
        [Char]
"the key still reads Active, from a fresh inspect"
        Requirement
ReachedActive
        (Receipt -> [Receipt]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Receipt -> [Receipt]) -> Story CliI Receipt -> Story [Receipt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliI Receipt -> Story CliI Receipt
forall (act :: * -> *) res. act res -> Story act res
action (Command -> Target -> [Char] -> CliI Receipt
Run Command
Inspect Target
target [Char]
heldKey))

{- | How many actions a story runs outside any clause, and, for each
telling, its clauses in order with whether each one's check is a premise.
The story is walked with placeholder receipts; it never branches on one.
-}
shape :: Story () -> (Int, [(String, [(String, Bool)])])
shape :: Story CliI () -> (Int, [([Char], [([Char], Bool)])])
shape = Story CliI () -> (Int, [([Char], [([Char], Bool)])])
forall a. Story a -> (Int, [([Char], [([Char], Bool)])])
go
  where
    go :: Story a -> (Int, [(String, [(String, Bool)])])
    go :: forall a. Story a -> (Int, [([Char], [([Char], Bool)])])
go Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
_ -> (Int
0, [])
        Action CliI b
i :>>= b -> Story a
next ->
            let (Int
n, [([Char], [([Char], Bool)])]
ts) = Story a -> (Int, [([Char], [([Char], Bool)])])
forall a. Story a -> (Int, [([Char], [([Char], Bool)])])
go (b -> Story a
next (CliI b -> b
forall a. CliI a -> a
placeholderOf CliI b
i)) in (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, [([Char], [([Char], Bool)])]
ts)
        Theorem Theorem thm
thm TheoremStory thm CliI b
body :>>= b -> Story a
next ->
            let ([([Char], Bool)]
cs, b
r) = Program (Clause thm CliI) b -> ([([Char], Bool)], b)
forall {k} (thm :: k) a.
Program (Clause thm CliI) a -> ([([Char], Bool)], a)
walkClauses (TheoremStory thm CliI b -> Program (Clause thm CliI) b
forall {k} (thm :: k) (act :: * -> *) res.
TheoremStory thm act res -> Program (Clause thm act) res
clauses TheoremStory thm CliI b
body)
                (Int
n, [([Char], [([Char], Bool)])]
ts) = Story a -> (Int, [([Char], [([Char], Bool)])])
forall a. Story a -> (Int, [([Char], [([Char], Bool)])])
go (b -> Story a
next b
r)
            in  (Int
n, (BoundObligation -> [Char]
boName (Theorem thm -> BoundObligation
forall {k} (thm :: k). Theorem thm -> BoundObligation
theoremBinding Theorem thm
thm), [([Char], Bool)]
cs) ([Char], [([Char], Bool)])
-> [([Char], [([Char], Bool)])] -> [([Char], [([Char], Bool)])]
forall a. a -> [a] -> [a]
: [([Char], [([Char], Bool)])]
ts)

    walkClauses :: Program (Clause thm CliI) a -> ([(String, Bool)], a)
    walkClauses :: forall {k} (thm :: k) a.
Program (Clause thm CliI) a -> ([([Char], Bool)], a)
walkClauses Program (Clause thm CliI) a
program = case Program (Clause thm CliI) a -> ProgramView (Clause thm CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Program (Clause thm CliI) a
program of
        Return a
a -> ([], a
a)
        Clause [Char]
title LeanCheck CliI thm b
leanCheck Story CliI b
body :>>= b -> Program (Clause thm CliI) a
next ->
            let obs :: b
obs = Story CliI b -> b
forall a. Story a -> a
result Story CliI b
body
                usesPremise :: Bool
usesPremise = (Requirement -> Bool) -> [Requirement] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Requirement -> [Requirement] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Requirement]
premises) (Story CliI () -> [Requirement]
forall a. Story a -> [Requirement]
requirementsOf (LeanCheck CliI thm b -> b -> Story CliI ()
forall {k} (act :: * -> *) (thm :: k) obs.
LeanCheck act thm obs -> obs -> Story act ()
checkAction LeanCheck CliI thm b
leanCheck b
obs))
                ([([Char], Bool)]
rest, a
a) = Program (Clause thm CliI) a -> ([([Char], Bool)], a)
forall {k} (thm :: k) a.
Program (Clause thm CliI) a -> ([([Char], Bool)], a)
walkClauses (b -> Program (Clause thm CliI) a
next b
obs)
            in  (([Char]
title, Bool
usesPremise) ([Char], Bool) -> [([Char], Bool)] -> [([Char], Bool)]
forall a. a -> [a] -> [a]
: [([Char], Bool)]
rest, a
a)

    result :: Story a -> a
    result :: forall a. Story a -> a
result Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
a -> a
a
        Action CliI b
i :>>= b -> Story a
next -> Story a -> a
forall a. Story a -> a
result (b -> Story a
next (CliI b -> b
forall a. CliI a -> a
placeholderOf CliI b
i))
        Theorem Theorem thm
_ TheoremStory thm CliI b
_ :>>= b -> Story a
_ -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"shape: a statement nested inside a clause"

    requirementsOf :: Story a -> [Requirement]
    requirementsOf :: forall a. Story a -> [Requirement]
requirementsOf Story a
program = case Story a -> ProgramView (Step CliI) a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
view Story a
program of
        Return a
_ -> []
        Action (Require Requirement
req [Receipt]
_) :>>= b -> Story a
next -> Requirement
req Requirement -> [Requirement] -> [Requirement]
forall a. a -> [a] -> [a]
: Story a -> [Requirement]
forall a. Story a -> [Requirement]
requirementsOf (b -> Story a
next ())
        Action CliI b
i :>>= b -> Story a
next -> Story a -> [Requirement]
forall a. Story a -> [Requirement]
requirementsOf (b -> Story a
next (CliI b -> b
forall a. CliI a -> a
placeholderOf CliI b
i))
        Theorem Theorem thm
_ TheoremStory thm CliI b
_ :>>= b -> Story a
_ -> []

    placeholderOf :: CliI a -> a
    placeholderOf :: forall a. CliI a -> a
placeholderOf CliI a
i = case CliI a
i of
        Require Requirement
_ [Receipt]
_ -> ()
        Retire [Char]
_ -> ()
        Run{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        RunByToken{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Book{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        FoldUnevaluated{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Observe{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Craft{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Provoke{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        Reclaim{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""
        ReadIndexer{} -> Int -> Text -> Text -> Text -> Receipt
emptyReceipt Int
0 Text
"" Text
"" Text
""

-- | One submission an ordinary command journalled, and the body it kept.
data Submission = Submission
    { Submission -> Text
suStep :: Text
    , Submission -> Text
suTxId :: Text
    , Submission -> Text
suBodyFile :: Text
    -- ^ Relative to the run's directory
    , Submission -> Text
suBodySha256 :: Text
    }
    deriving stock (Submission -> Submission -> Bool
(Submission -> Submission -> Bool)
-> (Submission -> Submission -> Bool) -> Eq Submission
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Submission -> Submission -> Bool
== :: Submission -> Submission -> Bool
$c/= :: Submission -> Submission -> Bool
/= :: Submission -> Submission -> Bool
Eq, Int -> Submission -> ShowS
[Submission] -> ShowS
Submission -> [Char]
(Int -> Submission -> ShowS)
-> (Submission -> [Char])
-> ([Submission] -> ShowS)
-> Show Submission
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Submission -> ShowS
showsPrec :: Int -> Submission -> ShowS
$cshow :: Submission -> [Char]
show :: Submission -> [Char]
$cshowList :: [Submission] -> ShowS
showList :: [Submission] -> ShowS
Show)

instance ToJSON Submission where
    toJSON :: Submission -> Value
toJSON Submission
s =
        [Pair] -> Value
object
            [ Key
"step" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Submission -> Text
suStep Submission
s
            , Key
"txId" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Submission -> Text
suTxId Submission
s
            , Key
"bodyFile" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Submission -> Text
suBodyFile Submission
s
            , Key
"bodySha256" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Submission -> Text
suBodySha256 Submission
s
            ]

instance FromJSON Submission where
    parseJSON :: Value -> Parser Submission
parseJSON = [Char]
-> (Object -> Parser Submission) -> Value -> Parser Submission
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"submission" ((Object -> Parser Submission) -> Value -> Parser Submission)
-> (Object -> Parser Submission) -> Value -> Parser Submission
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text -> Text -> Text -> Text -> Submission
Submission
            (Text -> Text -> Text -> Text -> Submission)
-> Parser Text -> Parser (Text -> Text -> Text -> Submission)
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
"step"
            Parser (Text -> Text -> Text -> Submission)
-> Parser Text -> Parser (Text -> Text -> Submission)
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
"txId"
            Parser (Text -> Text -> Submission)
-> Parser Text -> Parser (Text -> Submission)
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
"bodyFile"
            Parser (Text -> Submission) -> Parser Text -> Parser Submission
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
"bodySha256"

{- | A live output an ordinary command's journal read back without
submitting it: the transaction that published it, and the step that read it.
-}
data Resolved = Resolved
    { Resolved -> Text
reStep :: Text
    , Resolved -> Text
reTxId :: Text
    }
    deriving stock (Resolved -> Resolved -> Bool
(Resolved -> Resolved -> Bool)
-> (Resolved -> Resolved -> Bool) -> Eq Resolved
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Resolved -> Resolved -> Bool
== :: Resolved -> Resolved -> Bool
$c/= :: Resolved -> Resolved -> Bool
/= :: Resolved -> Resolved -> Bool
Eq, Int -> Resolved -> ShowS
[Resolved] -> ShowS
Resolved -> [Char]
(Int -> Resolved -> ShowS)
-> (Resolved -> [Char]) -> ([Resolved] -> ShowS) -> Show Resolved
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Resolved -> ShowS
showsPrec :: Int -> Resolved -> ShowS
$cshow :: Resolved -> [Char]
show :: Resolved -> [Char]
$cshowList :: [Resolved] -> ShowS
showList :: [Resolved] -> ShowS
Show)

instance ToJSON Resolved where
    toJSON :: Resolved -> Value
toJSON Resolved
x = [Pair] -> Value
object [Key
"step" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Resolved -> Text
reStep Resolved
x, Key
"txId" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Resolved -> Text
reTxId Resolved
x]

instance FromJSON Resolved where
    parseJSON :: Value -> Parser Resolved
parseJSON = [Char] -> (Object -> Parser Resolved) -> Value -> Parser Resolved
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"resolved" ((Object -> Parser Resolved) -> Value -> Parser Resolved)
-> (Object -> Parser Resolved) -> Value -> Parser Resolved
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text -> Text -> Resolved
Resolved (Text -> Text -> Resolved)
-> Parser Text -> Parser (Text -> Resolved)
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
"step" Parser (Text -> Resolved) -> Parser Text -> Parser Resolved
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
"txId"

{- | The lines an ordinary command's registry journal gained while it ran:
the journal, relative to the run's directory, the line counts before and
after, and the SHA-256 of those lines as they stand in the file. Admission
re-derives from them what the command submitted and what it only read back.
-}
data JournalSpan = JournalSpan
    { JournalSpan -> Text
jsFile :: Text
    , JournalSpan -> Int
jsBefore :: Int
    , JournalSpan -> Int
jsAfter :: Int
    , JournalSpan -> Text
jsSha256 :: Text
    }
    deriving stock (JournalSpan -> JournalSpan -> Bool
(JournalSpan -> JournalSpan -> Bool)
-> (JournalSpan -> JournalSpan -> Bool) -> Eq JournalSpan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JournalSpan -> JournalSpan -> Bool
== :: JournalSpan -> JournalSpan -> Bool
$c/= :: JournalSpan -> JournalSpan -> Bool
/= :: JournalSpan -> JournalSpan -> Bool
Eq, Int -> JournalSpan -> ShowS
[JournalSpan] -> ShowS
JournalSpan -> [Char]
(Int -> JournalSpan -> ShowS)
-> (JournalSpan -> [Char])
-> ([JournalSpan] -> ShowS)
-> Show JournalSpan
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JournalSpan -> ShowS
showsPrec :: Int -> JournalSpan -> ShowS
$cshow :: JournalSpan -> [Char]
show :: JournalSpan -> [Char]
$cshowList :: [JournalSpan] -> ShowS
showList :: [JournalSpan] -> ShowS
Show)

instance ToJSON JournalSpan where
    toJSON :: JournalSpan -> Value
toJSON JournalSpan
j =
        [Pair] -> Value
object
            [ Key
"file" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JournalSpan -> Text
jsFile JournalSpan
j
            , Key
"before" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JournalSpan -> Int
jsBefore JournalSpan
j
            , Key
"after" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JournalSpan -> Int
jsAfter JournalSpan
j
            , Key
"sha256" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JournalSpan -> Text
jsSha256 JournalSpan
j
            ]

instance FromJSON JournalSpan where
    parseJSON :: Value -> Parser JournalSpan
parseJSON = [Char]
-> (Object -> Parser JournalSpan) -> Value -> Parser JournalSpan
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"journal" ((Object -> Parser JournalSpan) -> Value -> Parser JournalSpan)
-> (Object -> Parser JournalSpan) -> Value -> Parser JournalSpan
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text -> Int -> Int -> Text -> JournalSpan
JournalSpan
            (Text -> Int -> Int -> Text -> JournalSpan)
-> Parser Text -> Parser (Int -> Int -> Text -> JournalSpan)
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
"file"
            Parser (Int -> Int -> Text -> JournalSpan)
-> Parser Int -> Parser (Int -> Text -> JournalSpan)
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 Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"before"
            Parser (Int -> Text -> JournalSpan)
-> Parser Int -> Parser (Text -> JournalSpan)
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 Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"after"
            Parser (Text -> JournalSpan) -> Parser Text -> Parser JournalSpan
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
"sha256"

{- | What a provoked command's process left, as the backend recorded it.
Admission reads each part back from the run's files — the registry's
journal, the saved files, the printed receipts — and a recorded part that
differs from them is a problem, never a fact.
-}
data ProcessEvidence = ProcessEvidence
    { ProcessEvidence -> Text
peJournal :: Text
    -- ^ The registry's journal, relative to the run's directory
    , ProcessEvidence -> Int
peJournalBefore :: Int
    -- ^ Its lines before the command started
    , ProcessEvidence -> Int
peJournalAfter :: Int
    -- ^ Its lines once the command had stopped
    , ProcessEvidence -> Text
peLastEvent :: Text
    -- ^ @step/event@ of the journal's last line once the command had stopped
    , ProcessEvidence -> [Text]
peSubmitted :: [Text]
    -- ^ The transactions the journal says the command submitted
    , ProcessEvidence -> Int
peExit :: Int
    -- ^ The exit status; the negated signal for a process killed by one
    , ProcessEvidence -> Maybe Int
peWaited :: Maybe Int
    -- ^ Seconds from the command's release to its exit
    , ProcessEvidence -> [(Text, Text)]
peFilesBefore :: [(Text, Text)]
    -- ^ Saved files of a registry the command must not touch, and digests, before
    , ProcessEvidence -> [(Text, Text)]
peFilesAfter :: [(Text, Text)]
    -- ^ The same, once the command had stopped
    , ProcessEvidence -> Maybe Text
peSeedProbe :: Maybe Text
    {- ^ The printed receipt of a preview naming the command's seed, run
    once the command had stopped: it succeeds only while the seed is unspent
    -}
    }
    deriving stock (ProcessEvidence -> ProcessEvidence -> Bool
(ProcessEvidence -> ProcessEvidence -> Bool)
-> (ProcessEvidence -> ProcessEvidence -> Bool)
-> Eq ProcessEvidence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProcessEvidence -> ProcessEvidence -> Bool
== :: ProcessEvidence -> ProcessEvidence -> Bool
$c/= :: ProcessEvidence -> ProcessEvidence -> Bool
/= :: ProcessEvidence -> ProcessEvidence -> Bool
Eq, Int -> ProcessEvidence -> ShowS
[ProcessEvidence] -> ShowS
ProcessEvidence -> [Char]
(Int -> ProcessEvidence -> ShowS)
-> (ProcessEvidence -> [Char])
-> ([ProcessEvidence] -> ShowS)
-> Show ProcessEvidence
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProcessEvidence -> ShowS
showsPrec :: Int -> ProcessEvidence -> ShowS
$cshow :: ProcessEvidence -> [Char]
show :: ProcessEvidence -> [Char]
$cshowList :: [ProcessEvidence] -> ShowS
showList :: [ProcessEvidence] -> ShowS
Show)

instance ToJSON ProcessEvidence where
    toJSON :: ProcessEvidence -> Value
toJSON ProcessEvidence
p =
        [Pair] -> Value
object
            [ Key
"journal" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> Text
peJournal ProcessEvidence
p
            , Key
"journalBefore" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> Int
peJournalBefore ProcessEvidence
p
            , Key
"journalAfter" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> Int
peJournalAfter ProcessEvidence
p
            , Key
"lastEvent" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> Text
peLastEvent ProcessEvidence
p
            , Key
"submitted" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> [Text]
peSubmitted ProcessEvidence
p
            , Key
"exit" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> Int
peExit ProcessEvidence
p
            , Key
"waitedSeconds" Key -> Maybe Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> Maybe Int
peWaited ProcessEvidence
p
            , Key
"filesBefore" Key -> [(Text, Text)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> [(Text, Text)]
peFilesBefore ProcessEvidence
p
            , Key
"filesAfter" Key -> [(Text, Text)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> [(Text, Text)]
peFilesAfter ProcessEvidence
p
            , Key
"seedProbe" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProcessEvidence -> Maybe Text
peSeedProbe ProcessEvidence
p
            ]

instance FromJSON ProcessEvidence where
    parseJSON :: Value -> Parser ProcessEvidence
parseJSON = [Char]
-> (Object -> Parser ProcessEvidence)
-> Value
-> Parser ProcessEvidence
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"process" ((Object -> Parser ProcessEvidence)
 -> Value -> Parser ProcessEvidence)
-> (Object -> Parser ProcessEvidence)
-> Value
-> Parser ProcessEvidence
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        Text
-> Int
-> Int
-> Text
-> [Text]
-> Int
-> Maybe Int
-> [(Text, Text)]
-> [(Text, Text)]
-> Maybe Text
-> ProcessEvidence
ProcessEvidence
            (Text
 -> Int
 -> Int
 -> Text
 -> [Text]
 -> Int
 -> Maybe Int
 -> [(Text, Text)]
 -> [(Text, Text)]
 -> Maybe Text
 -> ProcessEvidence)
-> Parser Text
-> Parser
     (Int
      -> Int
      -> Text
      -> [Text]
      -> Int
      -> Maybe Int
      -> [(Text, Text)]
      -> [(Text, Text)]
      -> Maybe Text
      -> ProcessEvidence)
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
"journal"
            Parser
  (Int
   -> Int
   -> Text
   -> [Text]
   -> Int
   -> Maybe Int
   -> [(Text, Text)]
   -> [(Text, Text)]
   -> Maybe Text
   -> ProcessEvidence)
-> Parser Int
-> Parser
     (Int
      -> Text
      -> [Text]
      -> Int
      -> Maybe Int
      -> [(Text, Text)]
      -> [(Text, Text)]
      -> Maybe Text
      -> ProcessEvidence)
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 Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"journalBefore"
            Parser
  (Int
   -> Text
   -> [Text]
   -> Int
   -> Maybe Int
   -> [(Text, Text)]
   -> [(Text, Text)]
   -> Maybe Text
   -> ProcessEvidence)
-> Parser Int
-> Parser
     (Text
      -> [Text]
      -> Int
      -> Maybe Int
      -> [(Text, Text)]
      -> [(Text, Text)]
      -> Maybe Text
      -> ProcessEvidence)
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 Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"journalAfter"
            Parser
  (Text
   -> [Text]
   -> Int
   -> Maybe Int
   -> [(Text, Text)]
   -> [(Text, Text)]
   -> Maybe Text
   -> ProcessEvidence)
-> Parser Text
-> Parser
     ([Text]
      -> Int
      -> Maybe Int
      -> [(Text, Text)]
      -> [(Text, Text)]
      -> Maybe Text
      -> ProcessEvidence)
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
"lastEvent"
            Parser
  ([Text]
   -> Int
   -> Maybe Int
   -> [(Text, Text)]
   -> [(Text, Text)]
   -> Maybe Text
   -> ProcessEvidence)
-> Parser [Text]
-> Parser
     (Int
      -> Maybe Int
      -> [(Text, Text)]
      -> [(Text, Text)]
      -> Maybe Text
      -> ProcessEvidence)
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
"submitted"
            Parser
  (Int
   -> Maybe Int
   -> [(Text, Text)]
   -> [(Text, Text)]
   -> Maybe Text
   -> ProcessEvidence)
-> Parser Int
-> Parser
     (Maybe Int
      -> [(Text, Text)]
      -> [(Text, Text)]
      -> Maybe Text
      -> ProcessEvidence)
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 Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"exit"
            Parser
  (Maybe Int
   -> [(Text, Text)]
   -> [(Text, Text)]
   -> Maybe Text
   -> ProcessEvidence)
-> Parser (Maybe Int)
-> Parser
     ([(Text, Text)] -> [(Text, Text)] -> Maybe Text -> ProcessEvidence)
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 Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"waitedSeconds"
            Parser
  ([(Text, Text)] -> [(Text, Text)] -> Maybe Text -> ProcessEvidence)
-> Parser [(Text, Text)]
-> Parser ([(Text, Text)] -> Maybe Text -> ProcessEvidence)
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, Text)]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"filesBefore"
            Parser ([(Text, Text)] -> Maybe Text -> ProcessEvidence)
-> Parser [(Text, Text)] -> Parser (Maybe Text -> ProcessEvidence)
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, Text)]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"filesAfter"
            Parser (Maybe Text -> ProcessEvidence)
-> Parser (Maybe Text) -> Parser ProcessEvidence
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
"seedProbe"

-- | Saved files by name and digest, wherever they were read.
byName :: [(Text, Text)] -> [(Text, Text)]
byName :: [(Text, Text)] -> [(Text, Text)]
byName = ((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> (Text, Text) -> (Text, Text)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bifunctor.first ((Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/')))