{- | The payments an accepted exit made, read off its transaction.

The chain settles a fold per payee. A fold that delivers a token pays the
deposit with it: the output carrying the token holds at least the deposit. A
fold that delivers nothing, and a reject, pay the request's owner: the owner is
credited the summed lovelace of every output at the owner's payment key that
carries no token the fold delivers. An absent insertion locks the deposit in the
custody output it creates. A spent custody's refund address is credited the
summed lovelace of every output at that address carrying no delivered token. A
retraction returns what the request held through one output at the owner's key
whose inline datum is the retracted request's own output reference: the largest
such output is what the chain reads, never a sum of fragments. Every
amount is read as the chain paid it, never selected by the amount the model
expects, so a short or surplus payment reaches the comparison. This module
reads those payments in the chain's own terms — addresses, keys and lovelace —
and leaves their translation to model identities to the live runner, which
allocated them.
-}
module Conformance.Observe.Payments
    ( FoldOutput (..)
    , ExitFacts (..)
    , Payee (..)
    , Payment (..)
    , foldPayments
    , creditsOwner
    , OwnerReading (..)
    , readOwner
    , readBound
    , ownerOutputObservation
    , OwedPayee (..)
    , owedPayee
    , owedOutputs
    , OutputEdit (..)
    , tamperEdits
    ) where

import Conformance.Story.Live (Edge (..), Exit (..), Tamper (..))
import Data.Aeson (Value (..), object, (.=))
import Data.ByteString (ByteString)
import Data.List (maximumBy, nub)
import Data.Maybe (isJust)
import Data.Ord (comparing)
import Data.Text (Text)

-- | One output of the fold's transaction, reduced to what settlement reads.
data FoldOutput = FoldOutput
    { FoldOutput -> ByteString
outputAddress :: ByteString
    -- ^ the serialised address
    , FoldOutput -> ByteString
outputKey :: ByteString
    -- ^ the payment key hash; empty for a script credential
    , FoldOutput -> Integer
outputLovelace :: Integer
    , FoldOutput -> Bool
outputCarrier :: Bool
    -- ^ holds a token this fold delivers
    , FoldOutput -> Text
outputDatum :: Text
    -- ^ the datum form the output presents: @none@, @hashed@ or @inline@
    , FoldOutput -> [Text]
outputApprovals :: [Text]
    -- ^ the hex names of the application-policy assets it holds
    , FoldOutput -> Bool
outputCustody :: Bool
    -- ^ holds an absent custody datum at the cage
    , FoldOutput -> Maybe Text
outputReference :: Maybe Text
    -- ^ the output reference its inline datum presents, if it presents one
    }
    deriving stock (FoldOutput -> FoldOutput -> Bool
(FoldOutput -> FoldOutput -> Bool)
-> (FoldOutput -> FoldOutput -> Bool) -> Eq FoldOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FoldOutput -> FoldOutput -> Bool
== :: FoldOutput -> FoldOutput -> Bool
$c/= :: FoldOutput -> FoldOutput -> Bool
/= :: FoldOutput -> FoldOutput -> Bool
Eq, Int -> FoldOutput -> ShowS
[FoldOutput] -> ShowS
FoldOutput -> String
(Int -> FoldOutput -> ShowS)
-> (FoldOutput -> String)
-> ([FoldOutput] -> ShowS)
-> Show FoldOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FoldOutput -> ShowS
showsPrec :: Int -> FoldOutput -> ShowS
$cshow :: FoldOutput -> String
show :: FoldOutput -> String
$cshowList :: [FoldOutput] -> ShowS
showList :: [FoldOutput] -> ShowS
Show)

-- | What the chain records about the exit beside its outputs.
data ExitFacts = ExitFacts
    { ExitFacts -> Exit
factsExit :: Exit
    , ExitFacts -> Edge
factsEdge :: Edge
    , ExitFacts -> ByteString
factsOwner :: ByteString
    -- ^ the payment key hash the request names as its owner
    , ExitFacts -> Maybe ByteString
factsRefund :: Maybe ByteString
    -- ^ the refund address of the custody this fold spent
    , ExitFacts -> Maybe Text
factsReference :: Maybe Text
    -- ^ the output reference the request sat at
    }
    deriving stock (ExitFacts -> ExitFacts -> Bool
(ExitFacts -> ExitFacts -> Bool)
-> (ExitFacts -> ExitFacts -> Bool) -> Eq ExitFacts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExitFacts -> ExitFacts -> Bool
== :: ExitFacts -> ExitFacts -> Bool
$c/= :: ExitFacts -> ExitFacts -> Bool
/= :: ExitFacts -> ExitFacts -> Bool
Eq, Int -> ExitFacts -> ShowS
[ExitFacts] -> ShowS
ExitFacts -> String
(Int -> ExitFacts -> ShowS)
-> (ExitFacts -> String)
-> ([ExitFacts] -> ShowS)
-> Show ExitFacts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExitFacts -> ShowS
showsPrec :: Int -> ExitFacts -> ShowS
$cshow :: ExitFacts -> String
show :: ExitFacts -> String
$cshowList :: [ExitFacts] -> ShowS
showList :: [ExitFacts] -> ShowS
Show)

-- | Who a payment reached, in the chain's terms.
data Payee
    = -- | the cage's custody
      Custody
    | -- | the address holding the delivered token
      Destination ByteString
    | -- | the request owner's payment key
      Owner ByteString
    | -- | the refund address a spent custody recorded
      Refund ByteString
    deriving stock (Payee -> Payee -> Bool
(Payee -> Payee -> Bool) -> (Payee -> Payee -> Bool) -> Eq Payee
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Payee -> Payee -> Bool
== :: Payee -> Payee -> Bool
$c/= :: Payee -> Payee -> Bool
/= :: Payee -> Payee -> Bool
Eq, Int -> Payee -> ShowS
[Payee] -> ShowS
Payee -> String
(Int -> Payee -> ShowS)
-> (Payee -> String) -> ([Payee] -> ShowS) -> Show Payee
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Payee -> ShowS
showsPrec :: Int -> Payee -> ShowS
$cshow :: Payee -> String
show :: Payee -> String
$cshowList :: [Payee] -> ShowS
showList :: [Payee] -> ShowS
Show)

-- | A payment the fold made: its payee and the lovelace that reached it.
data Payment = Payment
    { Payment -> Payee
payee :: Payee
    , Payment -> Integer
paidLovelace :: Integer
    }
    deriving stock (Payment -> Payment -> Bool
(Payment -> Payment -> Bool)
-> (Payment -> Payment -> Bool) -> Eq Payment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Payment -> Payment -> Bool
== :: Payment -> Payment -> Bool
$c/= :: Payment -> Payment -> Bool
/= :: Payment -> Payment -> Bool
Eq, Int -> Payment -> ShowS
[Payment] -> ShowS
Payment -> String
(Int -> Payment -> ShowS)
-> (Payment -> String) -> ([Payment] -> ShowS) -> Show Payment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Payment -> ShowS
showsPrec :: Int -> Payment -> ShowS
$cshow :: Payment -> String
show :: Payment -> String
$cshowList :: [Payment] -> ShowS
showList :: [Payment] -> ShowS
Show)

{- | The payments of one accepted fold, in the order the model states them:
what the fold owes for its request, then the custody refund it pays.

What is owed is reported as the chain paid it, however much that is, so a
short payment reaches the comparison as a value below the model's floor. What
cannot be read as a payment at all — a delivered token no single output
carries, a custody lock that is not there, a spent custody whose source was not
observed — is refused rather than reported.
-}
foldPayments :: ExitFacts -> [FoldOutput] -> Either String [Payment]
foldPayments :: ExitFacts -> [FoldOutput] -> Either String [Payment]
foldPayments ExitFacts
facts [FoldOutput]
outputs = [Payment] -> [Payment] -> [Payment]
forall a. Semigroup a => a -> a -> a
(<>) ([Payment] -> [Payment] -> [Payment])
-> Either String [Payment]
-> Either String ([Payment] -> [Payment])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String [Payment]
owed Either String ([Payment] -> [Payment])
-> Either String [Payment] -> Either String [Payment]
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either String [Payment]
refunds
  where
    owing :: [FoldOutput]
owing = (Int -> FoldOutput) -> [Int] -> [FoldOutput]
forall a b. (a -> b) -> [a] -> [b]
map ([FoldOutput]
outputs [FoldOutput] -> Int -> FoldOutput
forall a. HasCallStack => [a] -> Int -> a
!!) (ExitFacts -> [FoldOutput] -> [Int]
owedOutputs ExitFacts
facts [FoldOutput]
outputs)
    owed :: Either String [Payment]
owed = case ExitFacts -> OwedPayee
owedPayee ExitFacts
facts of
        OwedPayee
OwedCustody -> case [FoldOutput]
owing of
            [FoldOutput
custody] -> [Payment] -> Either String [Payment]
forall a b. b -> Either a b
Right [Payee -> Integer -> Payment
Payment Payee
Custody (FoldOutput -> Integer
outputLovelace FoldOutput
custody)]
            [FoldOutput]
_ -> String -> Either String [Payment]
forall a b. a -> Either a b
Left String
"insertAbsent locked no single custody output"
        OwedPayee
OwedCarrier -> case [FoldOutput]
owing of
            [FoldOutput
carrier] ->
                [Payment] -> Either String [Payment]
forall a b. b -> Either a b
Right
                    [ Payee -> Integer -> Payment
Payment (ByteString -> Payee
Destination (FoldOutput -> ByteString
outputAddress FoldOutput
carrier)) (FoldOutput -> Integer
outputLovelace FoldOutput
carrier)
                    ]
            [FoldOutput]
_ -> String -> Either String [Payment]
forall a b. a -> Either a b
Left String
"the delivered token is carried by no single output"
        OwedPayee
OwedOwner ->
            [Payment] -> Either String [Payment]
forall a b. b -> Either a b
Right
                [Payee -> Integer -> Payment
Payment (ByteString -> Payee
Owner (ExitFacts -> ByteString
factsOwner ExitFacts
facts)) ([Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((FoldOutput -> Integer) -> [FoldOutput] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map FoldOutput -> Integer
outputLovelace [FoldOutput]
owing))]
        OwedPayee
OwedBound ->
            [Payment] -> Either String [Payment]
forall a b. b -> Either a b
Right
                [ Payee -> Integer -> Payment
Payment
                    (ByteString -> Payee
Owner (ExitFacts -> ByteString
factsOwner ExitFacts
facts))
                    ([Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Integer
0 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: (FoldOutput -> Integer) -> [FoldOutput] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map FoldOutput -> Integer
outputLovelace [FoldOutput]
owing))
                ]
    -- A reject or a retraction consumes no custody, whatever edge it named.
    refunds :: Either String [Payment]
refunds = case (ExitFacts -> Exit
factsExit ExitFacts
facts, ExitFacts -> Edge
factsEdge ExitFacts
facts, ExitFacts -> Maybe ByteString
factsRefund ExitFacts
facts) of
        (Exit
Fold, Edge
UpdateActive, Just ByteString
refund) -> ByteString -> Either String [Payment]
forall {a}. ByteString -> Either a [Payment]
custodyRefund ByteString
refund
        (Exit
Fold, Edge
DeleteAbsent, Just ByteString
refund) -> ByteString -> Either String [Payment]
forall {a}. ByteString -> Either a [Payment]
custodyRefund ByteString
refund
        (Exit
Fold, Edge
UpdateActive, Maybe ByteString
Nothing) -> String -> Either String [Payment]
forall a b. a -> Either a b
Left String
"updateActive has no observed custody source"
        (Exit
Fold, Edge
DeleteAbsent, Maybe ByteString
Nothing) -> String -> Either String [Payment]
forall a b. a -> Either a b
Left String
"deleteAbsent has no observed custody source"
        (Exit, Edge, Maybe ByteString)
_ -> [Payment] -> Either String [Payment]
forall a b. b -> Either a b
Right []
    custodyRefund :: ByteString -> Either a [Payment]
custodyRefund ByteString
address =
        [Payment] -> Either a [Payment]
forall a b. b -> Either a b
Right
            [ Payee -> Integer -> Payment
Payment
                (ByteString -> Payee
Refund ByteString
address)
                ( [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
                    [ FoldOutput -> Integer
outputLovelace FoldOutput
out
                    | FoldOutput
out <- [FoldOutput]
outputs
                    , FoldOutput -> ByteString
outputAddress FoldOutput
out ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
address
                    , Bool -> Bool
not (FoldOutput -> Bool
outputCarrier FoldOutput
out)
                    ]
                )
            ]

{- | Whether the chain credits an output to an owner's key: it sits at that
payment key and carries no token the fold delivers.
-}
creditsOwner :: ByteString -> FoldOutput -> Bool
creditsOwner :: ByteString -> FoldOutput -> Bool
creditsOwner ByteString
owner FoldOutput
out = FoldOutput -> ByteString
outputKey FoldOutput
out ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
owner Bool -> Bool -> Bool
&& Bool -> Bool
not (FoldOutput -> Bool
outputCarrier FoldOutput
out)

-- | Whom an exit owes its request's payment, and so which outputs pay it.
data OwedPayee = OwedCustody | OwedCarrier | OwedOwner | OwedBound

{- | Whom this exit owes its request's payment: the model's rule, by edge for a
fold; a reject owes the owner, a retraction the owner through a bound output.
-}
owedPayee :: ExitFacts -> OwedPayee
owedPayee :: ExitFacts -> OwedPayee
owedPayee ExitFacts
facts = case (ExitFacts -> Exit
factsExit ExitFacts
facts, ExitFacts -> Edge
factsEdge ExitFacts
facts) of
    (Exit
Reject, Edge
_) -> OwedPayee
OwedOwner
    (Exit
Retract, Edge
_) -> OwedPayee
OwedBound
    (Exit
Fold, Edge
InsertAbsent) -> OwedPayee
OwedCustody
    (Exit
Fold, Edge
InsertActive) -> OwedPayee
OwedCarrier
    (Exit
Fold, Edge
UpdateActive) -> OwedPayee
OwedCarrier
    (Exit
Fold, Edge
WitnessTerminal) -> OwedPayee
OwedCarrier
    (Exit
Fold, Edge
UpdateTerminal) -> OwedPayee
OwedOwner
    (Exit
Fold, Edge
DeleteAbsent) -> OwedPayee
OwedOwner
    (Exit
Fold, Edge
DeleteActive) -> OwedPayee
OwedOwner

{- | Whether an output returns a retracted request: it credits the owner's key
and its inline datum presents the request's own output reference.
-}
bindsTo :: ByteString -> Maybe Text -> FoldOutput -> Bool
bindsTo :: ByteString -> Maybe Text -> FoldOutput -> Bool
bindsTo ByteString
owner Maybe Text
reference FoldOutput
out =
    ByteString -> FoldOutput -> Bool
creditsOwner ByteString
owner FoldOutput
out
        Bool -> Bool -> Bool
&& FoldOutput -> Text
outputDatum FoldOutput
out Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"inline"
        Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
reference
        Bool -> Bool -> Bool
&& FoldOutput -> Maybe Text
outputReference FoldOutput
out Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
reference

{- | The positions of the outputs through which the chain settles what an exit
owes for its request: the custody output an absent insertion locks, the
outputs carrying a token the fold delivers, for a fold delivering nothing and a
reject every output crediting the owner's key, and for a retraction every
output crediting it bound to the retracted request.
-}
owedOutputs :: ExitFacts -> [FoldOutput] -> [Int]
owedOutputs :: ExitFacts -> [FoldOutput] -> [Int]
owedOutputs ExitFacts
facts [FoldOutput]
outputs = [Int
i | (Int
i, FoldOutput
out) <- [Int] -> [FoldOutput] -> [(Int, FoldOutput)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [FoldOutput]
outputs, FoldOutput -> Bool
pays FoldOutput
out]
  where
    pays :: FoldOutput -> Bool
pays = case ExitFacts -> OwedPayee
owedPayee ExitFacts
facts of
        OwedPayee
OwedCustody -> FoldOutput -> Bool
outputCustody
        OwedPayee
OwedCarrier -> FoldOutput -> Bool
outputCarrier
        OwedPayee
OwedOwner -> ByteString -> FoldOutput -> Bool
creditsOwner (ExitFacts -> ByteString
factsOwner ExitFacts
facts)
        OwedPayee
OwedBound -> ByteString -> Maybe Text -> FoldOutput -> Bool
bindsTo (ExitFacts -> ByteString
factsOwner ExitFacts
facts) (ExitFacts -> Maybe Text
factsReference ExitFacts
facts)

-- | A change to one output of the fold's transaction, by position.
data OutputEdit
    = -- | send the output to another address, value unchanged
      Readdress Int
    | -- | give the output this lovelace
      Relovelace Int Integer
    | -- | bind the output to another output reference
      Rebind Int
    | -- | spend the registry's state beside the request
      SpendState
    deriving stock (OutputEdit -> OutputEdit -> Bool
(OutputEdit -> OutputEdit -> Bool)
-> (OutputEdit -> OutputEdit -> Bool) -> Eq OutputEdit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutputEdit -> OutputEdit -> Bool
== :: OutputEdit -> OutputEdit -> Bool
$c/= :: OutputEdit -> OutputEdit -> Bool
/= :: OutputEdit -> OutputEdit -> Bool
Eq, Int -> OutputEdit -> ShowS
[OutputEdit] -> ShowS
OutputEdit -> String
(Int -> OutputEdit -> ShowS)
-> (OutputEdit -> String)
-> ([OutputEdit] -> ShowS)
-> Show OutputEdit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OutputEdit -> ShowS
showsPrec :: Int -> OutputEdit -> ShowS
$cshow :: OutputEdit -> String
show :: OutputEdit -> String
$cshowList :: [OutputEdit] -> ShowS
showList :: [OutputEdit] -> ShowS
Show)

{- | The edits a tamper makes to the payment an exit owes, read off the exit's
own outputs. 'OtherAddress' sends every output paying it elsewhere.
'ShortByOne' leaves the payee credited one lovelace less than the first output
paying it holds: that output loses one lovelace, every other output paying it
goes elsewhere, and the lovelace taken goes to the transaction's last output,
its change. 'OtherReference' binds every output returning a retracted request to
another output reference, and 'StateSpent' spends the registry's state beside
the retraction; neither applies to another exit. 'ExtraSigner' changes no
output.
-}
tamperEdits
    :: Tamper -> ExitFacts -> [FoldOutput] -> Either String [OutputEdit]
tamperEdits :: Tamper -> ExitFacts -> [FoldOutput] -> Either String [OutputEdit]
tamperEdits Tamper
alteration ExitFacts
facts [FoldOutput]
outputs = case (Tamper
alteration, ExitFacts -> [FoldOutput] -> [Int]
owedOutputs ExitFacts
facts [FoldOutput]
outputs) of
    (Tamper
BeforePhase2, [Int]
_) -> String -> Either String [OutputEdit]
forall a b. a -> Either a b
Left String
"a retraction's validity interval is not a payment edit"
    (Tamper
AfterPhase2, [Int]
_) -> String -> Either String [OutputEdit]
forall a b. a -> Either a b
Left String
"a retraction's validity interval is not a payment edit"
    (Tamper
ExtraSigner, [Int]
_) -> [OutputEdit] -> Either String [OutputEdit]
forall a b. b -> Either a b
Right []
    (Tamper
OtherReference, [Int]
owed) | Bool
retraction, Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
owed) -> [OutputEdit] -> Either String [OutputEdit]
forall a b. b -> Either a b
Right ((Int -> OutputEdit) -> [Int] -> [OutputEdit]
forall a b. (a -> b) -> [a] -> [b]
map Int -> OutputEdit
Rebind [Int]
owed)
    (Tamper
StateSpent, Int
_ : [Int]
_) | Bool
retraction -> [OutputEdit] -> Either String [OutputEdit]
forall a b. b -> Either a b
Right [OutputEdit
SpendState]
    (Tamper
OtherReference, [Int]
_) | Bool -> Bool
not Bool
retraction -> String -> Either String [OutputEdit]
forall a b. a -> Either a b
Left String
bindingOnly
    (Tamper
StateSpent, [Int]
_) | Bool -> Bool
not Bool
retraction -> String -> Either String [OutputEdit]
forall a b. a -> Either a b
Left String
bindingOnly
    (Tamper
_, []) -> String -> Either String [OutputEdit]
forall a b. a -> Either a b
Left String
"the transaction makes no output paying what the exit owes"
    (Tamper
OtherAddress, [Int]
owed) -> [OutputEdit] -> Either String [OutputEdit]
forall a b. b -> Either a b
Right ((Int -> OutputEdit) -> [Int] -> [OutputEdit]
forall a b. (a -> b) -> [a] -> [b]
map Int -> OutputEdit
Readdress [Int]
owed)
    (Tamper
ShortByOne, Int
first : [Int]
rest)
        | Int
change Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
first ->
            String -> Either String [OutputEdit]
forall a b. a -> Either a b
Left
                String
"the output paying what the fold owes is its last; no change can take the lovelace"
        | FoldOutput -> Bool
outputCarrier FoldOutput
changed
            Bool -> Bool -> Bool
|| FoldOutput -> Bool
outputCustody FoldOutput
changed
            Bool -> Bool -> Bool
|| Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (FoldOutput -> Maybe Text
outputReference FoldOutput
changed)
            Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
retraction Bool -> Bool -> Bool
&& Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FoldOutput -> [Text]
outputApprovals FoldOutput
changed))) ->
            String -> Either String [OutputEdit]
forall a b. a -> Either a b
Left String
"the last output is not change that pays nothing the exit owes"
        | Bool
otherwise ->
            [OutputEdit] -> Either String [OutputEdit]
forall a b. b -> Either a b
Right
                ( Int -> Integer -> OutputEdit
Relovelace Int
first (FoldOutput -> Integer
outputLovelace ([FoldOutput]
outputs [FoldOutput] -> Int -> FoldOutput
forall a. HasCallStack => [a] -> Int -> a
!! Int
first) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
                    OutputEdit -> [OutputEdit] -> [OutputEdit]
forall a. a -> [a] -> [a]
: (Int -> OutputEdit) -> [Int] -> [OutputEdit]
forall a b. (a -> b) -> [a] -> [b]
map Int -> OutputEdit
Readdress [Int]
rest
                        [OutputEdit] -> [OutputEdit] -> [OutputEdit]
forall a. Semigroup a => a -> a -> a
<> [Int -> Integer -> OutputEdit
Relovelace Int
change (FoldOutput -> Integer
outputLovelace FoldOutput
changed Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)]
                )
    (Tamper
_, [Int]
_) -> String -> Either String [OutputEdit]
forall a b. a -> Either a b
Left (String
"no edit for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Tamper -> String
forall a. Show a => a -> String
show Tamper
alteration)
  where
    change :: Int
change = [FoldOutput] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FoldOutput]
outputs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    changed :: FoldOutput
changed = [FoldOutput]
outputs [FoldOutput] -> Int -> FoldOutput
forall a. HasCallStack => [a] -> Int -> a
!! Int
change
    -- A retraction's change may carry the approval the request held: it returns
    -- no bound output, so it pays nothing the retraction owes.
    retraction :: Bool
retraction = ExitFacts -> Exit
factsExit ExitFacts
facts Exit -> Exit -> Bool
forall a. Eq a => a -> a -> Bool
== Exit
Retract
    bindingOnly :: String
bindingOnly =
        String
"only a retraction is bound to its request or refused for what it spends"

-- | The owner output as the ledger outputs crediting the owner present it.
data OwnerReading = OwnerReading
    { OwnerReading -> Integer
readingLovelace :: Integer
    -- ^ their summed lovelace
    , OwnerReading -> Text
readingDatum :: Text
    -- ^ the datum form they share
    , OwnerReading -> [Text]
readingApprovals :: [Text]
    -- ^ the distinct approval names they return
    }
    deriving stock (OwnerReading -> OwnerReading -> Bool
(OwnerReading -> OwnerReading -> Bool)
-> (OwnerReading -> OwnerReading -> Bool) -> Eq OwnerReading
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OwnerReading -> OwnerReading -> Bool
== :: OwnerReading -> OwnerReading -> Bool
$c/= :: OwnerReading -> OwnerReading -> Bool
/= :: OwnerReading -> OwnerReading -> Bool
Eq, Int -> OwnerReading -> ShowS
[OwnerReading] -> ShowS
OwnerReading -> String
(Int -> OwnerReading -> ShowS)
-> (OwnerReading -> String)
-> ([OwnerReading] -> ShowS)
-> Show OwnerReading
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OwnerReading -> ShowS
showsPrec :: Int -> OwnerReading -> ShowS
$cshow :: OwnerReading -> String
show :: OwnerReading -> String
$cshowList :: [OwnerReading] -> ShowS
showList :: [OwnerReading] -> ShowS
Show)

{- | Read the owner output off the outputs crediting the owner's key, or
nothing when no output credits it. Outputs presenting different datum forms
cannot be read as one owner output, and are refused.
-}
readOwner
    :: ByteString -> [FoldOutput] -> Either String (Maybe OwnerReading)
readOwner :: ByteString -> [FoldOutput] -> Either String (Maybe OwnerReading)
readOwner ByteString
owner [FoldOutput]
outputs = case (FoldOutput -> Bool) -> [FoldOutput] -> [FoldOutput]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> FoldOutput -> Bool
creditsOwner ByteString
owner) [FoldOutput]
outputs of
    [] -> Maybe OwnerReading -> Either String (Maybe OwnerReading)
forall a b. b -> Either a b
Right Maybe OwnerReading
forall a. Maybe a
Nothing
    [FoldOutput]
credited -> case [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ((FoldOutput -> Text) -> [FoldOutput] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FoldOutput -> Text
outputDatum [FoldOutput]
credited) of
        [Text
form] ->
            Maybe OwnerReading -> Either String (Maybe OwnerReading)
forall a b. b -> Either a b
Right
                ( OwnerReading -> Maybe OwnerReading
forall a. a -> Maybe a
Just
                    OwnerReading
                        { readingLovelace :: Integer
readingLovelace = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((FoldOutput -> Integer) -> [FoldOutput] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map FoldOutput -> Integer
outputLovelace [FoldOutput]
credited)
                        , readingDatum :: Text
readingDatum = Text
form
                        , readingApprovals :: [Text]
readingApprovals = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ((FoldOutput -> [Text]) -> [FoldOutput] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FoldOutput -> [Text]
outputApprovals [FoldOutput]
credited)
                        }
                )
        [Text]
_ ->
            String -> Either String (Maybe OwnerReading)
forall a b. a -> Either a b
Left String
"the outputs crediting the owner present different datum forms"

{- | The observed owner output, in the model's vocabulary: the owner's
identity, the lovelace and datum form read, the registry tokens and state
tokens it holds, the approval it returns, named by @approvalOf@ — the
run's own binding of each booked approval to its model name, which refuses a
name no booking established. Whichever approval the ledger returns is the one
reported, so another request's approval differs from the model's commitment. The
output reference its datum presents, if any, arrives as its identity.
-}
ownerOutputObservation
    :: Integer
    -> (Text -> Either String Integer)
    -> [Value]
    -> Integer
    -> Maybe Integer
    -> OwnerReading
    -> Either String Value
ownerOutputObservation :: Integer
-> (Text -> Either String Integer)
-> [Value]
-> Integer
-> Maybe Integer
-> OwnerReading
-> Either String Value
ownerOutputObservation Integer
owner Text -> Either String Integer
approvalOf [Value]
assets Integer
stateTokens Maybe Integer
reference OwnerReading
reading = do
    returned <- case OwnerReading -> [Text]
readingApprovals OwnerReading
reading of
        [] -> Value -> Either String Value
forall a b. b -> Either a b
Right Value
Null
        [Text
name] -> Scientific -> Value
Number (Scientific -> Value)
-> (Integer -> Scientific) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Value) -> Either String Integer -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String Integer
approvalOf Text
name
        [Text]
_ ->
            String -> Either String Value
forall a b. a -> Either a b
Left
                String
"the owner is returned several approvals; the model's owner output names one"
    pure
        ( object
            [ "role" .= String "owner"
            , "datum" .= String (readingDatum reading)
            , "address" .= owner
            , "stateToken" .= stateTokens
            , "inlineConfig" .= Null
            , "commitment" .= returned
            , "assets" .= assets
            , "custodyDatum" .= Null
            , "lovelace" .= readingLovelace reading
            , "reference" .= reference
            , "datumValue" .= Null
            ]
        )

{- | Read a retraction's return off the outputs crediting the owner's key and
bound to the output reference the request sat at, or nothing when no output is
bound to it. The chain settles a retraction by one sufficient bound output, so
the return is read as the largest of them, never a sum; whether it is enough
is the judgement's, not the reader's.
-}
readBound
    :: ByteString
    -> Text
    -> [FoldOutput]
    -> Either String (Maybe OwnerReading)
readBound :: ByteString
-> Text -> [FoldOutput] -> Either String (Maybe OwnerReading)
readBound ByteString
owner Text
reference [FoldOutput]
outputs = case (FoldOutput -> Bool) -> [FoldOutput] -> [FoldOutput]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> Maybe Text -> FoldOutput -> Bool
bindsTo ByteString
owner (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
reference)) [FoldOutput]
outputs of
    [] -> Maybe OwnerReading -> Either String (Maybe OwnerReading)
forall a b. b -> Either a b
Right Maybe OwnerReading
forall a. Maybe a
Nothing
    bound :: [FoldOutput]
bound@(FoldOutput
_ : [FoldOutput]
_) ->
        let largest :: FoldOutput
largest = (FoldOutput -> FoldOutput -> Ordering)
-> [FoldOutput] -> FoldOutput
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((FoldOutput -> Integer) -> FoldOutput -> FoldOutput -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing FoldOutput -> Integer
outputLovelace) [FoldOutput]
bound
        in  Maybe OwnerReading -> Either String (Maybe OwnerReading)
forall a b. b -> Either a b
Right
                ( OwnerReading -> Maybe OwnerReading
forall a. a -> Maybe a
Just
                    OwnerReading
                        { readingLovelace :: Integer
readingLovelace = FoldOutput -> Integer
outputLovelace FoldOutput
largest
                        , readingDatum :: Text
readingDatum = FoldOutput -> Text
outputDatum FoldOutput
largest
                        , readingApprovals :: [Text]
readingApprovals = FoldOutput -> [Text]
outputApprovals FoldOutput
largest
                        }
                )