{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE NoImplicitPrelude    #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:debug-context #-}
{-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:coverage-all #-}

-- | A general-purpose escrow contract in Plutus
module Plutus.Contracts.Tutorial.Escrow(
    -- $escrow
    Escrow
    , EscrowError(..)
    , AsEscrowError(..)
    , EscrowParams(..)
    , EscrowTarget(..)
    , payToPaymentPubKeyTarget
    , targetTotal
    , escrowContract
    , typedValidator
    -- * Actions
    , pay
    , payEp
    , redeem
    , redeemEp
    , refund
    , refundEp
    , RedeemFailReason(..)
    , RedeemSuccess(..)
    , RefundSuccess(..)
    , EscrowSchema
    -- * Exposed for test endpoints
    , Action(..)
    -- * Coverage
    , covIdx
    ) where

import Control.Lens (_1, has, makeClassyPrisms, only, review)
import Control.Monad (void)
import Control.Monad.Error.Lens (throwing)
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)

import Ledger (PaymentPubKeyHash (unPaymentPubKeyHash), TxId, getCardanoTxId)
import Ledger qualified
import Ledger.Tx qualified as Tx
import Ledger.Tx.Constraints (TxConstraints)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Typed.Scripts (TypedValidator)
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.Script.Utils.V2.Contexts (ScriptContext (..), TxInfo (..), txSignedBy)
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.Script.Utils.Value (Value, geq, lt)
import Plutus.V2.Ledger.Api (Datum (Datum), DatumHash)
import Plutus.V2.Ledger.Contexts (valuePaidTo)

import Cardano.Node.Emulator.Internal.Node.Params qualified as Params
import Plutus.Contract
import PlutusTx qualified
import PlutusTx.Code
import PlutusTx.Coverage
import PlutusTx.Prelude hiding (Applicative (..), Semigroup (..), check, foldMap)

import Prelude (Semigroup (..), foldMap)
import Prelude qualified as Haskell

type EscrowSchema =
        Endpoint "pay-escrow" Value
        .\/ Endpoint "redeem-escrow" ()
        .\/ Endpoint "refund-escrow" ()

data RedeemFailReason = DeadlinePassed | NotEnoughFundsAtAddress
    deriving stock (RedeemFailReason -> RedeemFailReason -> Bool
(RedeemFailReason -> RedeemFailReason -> Bool)
-> (RedeemFailReason -> RedeemFailReason -> Bool)
-> Eq RedeemFailReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RedeemFailReason -> RedeemFailReason -> Bool
$c/= :: RedeemFailReason -> RedeemFailReason -> Bool
== :: RedeemFailReason -> RedeemFailReason -> Bool
$c== :: RedeemFailReason -> RedeemFailReason -> Bool
Haskell.Eq, Int -> RedeemFailReason -> ShowS
[RedeemFailReason] -> ShowS
RedeemFailReason -> String
(Int -> RedeemFailReason -> ShowS)
-> (RedeemFailReason -> String)
-> ([RedeemFailReason] -> ShowS)
-> Show RedeemFailReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedeemFailReason] -> ShowS
$cshowList :: [RedeemFailReason] -> ShowS
show :: RedeemFailReason -> String
$cshow :: RedeemFailReason -> String
showsPrec :: Int -> RedeemFailReason -> ShowS
$cshowsPrec :: Int -> RedeemFailReason -> ShowS
Haskell.Show, (forall x. RedeemFailReason -> Rep RedeemFailReason x)
-> (forall x. Rep RedeemFailReason x -> RedeemFailReason)
-> Generic RedeemFailReason
forall x. Rep RedeemFailReason x -> RedeemFailReason
forall x. RedeemFailReason -> Rep RedeemFailReason x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RedeemFailReason x -> RedeemFailReason
$cfrom :: forall x. RedeemFailReason -> Rep RedeemFailReason x
Generic)
    deriving anyclass ([RedeemFailReason] -> Encoding
[RedeemFailReason] -> Value
RedeemFailReason -> Encoding
RedeemFailReason -> Value
(RedeemFailReason -> Value)
-> (RedeemFailReason -> Encoding)
-> ([RedeemFailReason] -> Value)
-> ([RedeemFailReason] -> Encoding)
-> ToJSON RedeemFailReason
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RedeemFailReason] -> Encoding
$ctoEncodingList :: [RedeemFailReason] -> Encoding
toJSONList :: [RedeemFailReason] -> Value
$ctoJSONList :: [RedeemFailReason] -> Value
toEncoding :: RedeemFailReason -> Encoding
$ctoEncoding :: RedeemFailReason -> Encoding
toJSON :: RedeemFailReason -> Value
$ctoJSON :: RedeemFailReason -> Value
ToJSON, Value -> Parser [RedeemFailReason]
Value -> Parser RedeemFailReason
(Value -> Parser RedeemFailReason)
-> (Value -> Parser [RedeemFailReason])
-> FromJSON RedeemFailReason
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RedeemFailReason]
$cparseJSONList :: Value -> Parser [RedeemFailReason]
parseJSON :: Value -> Parser RedeemFailReason
$cparseJSON :: Value -> Parser RedeemFailReason
FromJSON)

data EscrowError =
    RedeemFailed RedeemFailReason
    | RefundFailed
    | EContractError ContractError
    deriving stock (Int -> EscrowError -> ShowS
[EscrowError] -> ShowS
EscrowError -> String
(Int -> EscrowError -> ShowS)
-> (EscrowError -> String)
-> ([EscrowError] -> ShowS)
-> Show EscrowError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EscrowError] -> ShowS
$cshowList :: [EscrowError] -> ShowS
show :: EscrowError -> String
$cshow :: EscrowError -> String
showsPrec :: Int -> EscrowError -> ShowS
$cshowsPrec :: Int -> EscrowError -> ShowS
Haskell.Show, (forall x. EscrowError -> Rep EscrowError x)
-> (forall x. Rep EscrowError x -> EscrowError)
-> Generic EscrowError
forall x. Rep EscrowError x -> EscrowError
forall x. EscrowError -> Rep EscrowError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EscrowError x -> EscrowError
$cfrom :: forall x. EscrowError -> Rep EscrowError x
Generic)
    deriving anyclass ([EscrowError] -> Encoding
[EscrowError] -> Value
EscrowError -> Encoding
EscrowError -> Value
(EscrowError -> Value)
-> (EscrowError -> Encoding)
-> ([EscrowError] -> Value)
-> ([EscrowError] -> Encoding)
-> ToJSON EscrowError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [EscrowError] -> Encoding
$ctoEncodingList :: [EscrowError] -> Encoding
toJSONList :: [EscrowError] -> Value
$ctoJSONList :: [EscrowError] -> Value
toEncoding :: EscrowError -> Encoding
$ctoEncoding :: EscrowError -> Encoding
toJSON :: EscrowError -> Value
$ctoJSON :: EscrowError -> Value
ToJSON, Value -> Parser [EscrowError]
Value -> Parser EscrowError
(Value -> Parser EscrowError)
-> (Value -> Parser [EscrowError]) -> FromJSON EscrowError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [EscrowError]
$cparseJSONList :: Value -> Parser [EscrowError]
parseJSON :: Value -> Parser EscrowError
$cparseJSON :: Value -> Parser EscrowError
FromJSON)

makeClassyPrisms ''EscrowError

instance AsContractError EscrowError where
    _ContractError :: p ContractError (f ContractError) -> p EscrowError (f EscrowError)
_ContractError = p ContractError (f ContractError) -> p EscrowError (f EscrowError)
forall r. AsEscrowError r => Prism' r ContractError
_EContractError

-- This is a simplified version of the Escrow contract, which does not
-- enforce a deadline on payments or redemption, and also allows
-- Refund actions at any time.

-- $escrow
-- The escrow contract implements the exchange of value between multiple
-- parties. It is defined by a list of targets (public keys and script
-- addresses, each associated with a value). It works similar to the
-- crowdfunding contract in that the contributions can be made independently,
-- and the funds can be unlocked only by a transaction that pays the correct
-- amount to each target. A refund is possible if the outputs locked by the
-- contract have not been spent by the deadline. (Compared to the crowdfunding
-- contract, the refund policy is simpler because here because there is no
-- "collection period" during which the outputs may be spent after the deadline
-- has passed. This is because we're assuming that the participants in the
-- escrow contract will make their deposits as quickly as possible after
-- agreeing on a deal)
--
-- The contract supports two modes of operation, manual and automatic. In
-- manual mode, all actions are driven by endpoints that exposed via 'payEp'
-- 'redeemEp' and 'refundEp'. In automatic mode, the 'pay', 'redeem' and
-- 'refund'actions start immediately. This mode is useful when the escrow is
-- called from within another contract, for example during setup (collection of
-- the initial deposits).

-- | Defines where the money should go. Usually we have `d = Datum` (when
--   defining `EscrowTarget` values in off-chain code). Sometimes we have
--   `d = DatumHash` (when checking the hashes in on-chain code)
data EscrowTarget d =
    PaymentPubKeyTarget PaymentPubKeyHash Value
    deriving ((a -> b) -> EscrowTarget a -> EscrowTarget b
(forall a b. (a -> b) -> EscrowTarget a -> EscrowTarget b)
-> (forall a b. a -> EscrowTarget b -> EscrowTarget a)
-> Functor EscrowTarget
forall a b. a -> EscrowTarget b -> EscrowTarget a
forall a b. (a -> b) -> EscrowTarget a -> EscrowTarget b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EscrowTarget b -> EscrowTarget a
$c<$ :: forall a b. a -> EscrowTarget b -> EscrowTarget a
fmap :: (a -> b) -> EscrowTarget a -> EscrowTarget b
$cfmap :: forall a b. (a -> b) -> EscrowTarget a -> EscrowTarget b
Haskell.Functor)

PlutusTx.makeLift ''EscrowTarget

-- | An 'EscrowTarget' that pays the value to a public key address.
payToPaymentPubKeyTarget :: PaymentPubKeyHash -> Value -> EscrowTarget d
payToPaymentPubKeyTarget :: PaymentPubKeyHash -> Value -> EscrowTarget d
payToPaymentPubKeyTarget = PaymentPubKeyHash -> Value -> EscrowTarget d
forall d. PaymentPubKeyHash -> Value -> EscrowTarget d
PaymentPubKeyTarget

-- | Definition of an escrow contract, consisting of a deadline and a list of targets
newtype EscrowParams d =
    EscrowParams
        { EscrowParams d -> [EscrowTarget d]
escrowTargets  :: [EscrowTarget d]
        -- ^ Where the money should go. For each target, the contract checks that
        --   the output 'mkTxOutput' of the target is present in the spending
        --   transaction.
        } deriving ((a -> b) -> EscrowParams a -> EscrowParams b
(forall a b. (a -> b) -> EscrowParams a -> EscrowParams b)
-> (forall a b. a -> EscrowParams b -> EscrowParams a)
-> Functor EscrowParams
forall a b. a -> EscrowParams b -> EscrowParams a
forall a b. (a -> b) -> EscrowParams a -> EscrowParams b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EscrowParams b -> EscrowParams a
$c<$ :: forall a b. a -> EscrowParams b -> EscrowParams a
fmap :: (a -> b) -> EscrowParams a -> EscrowParams b
$cfmap :: forall a b. (a -> b) -> EscrowParams a -> EscrowParams b
Haskell.Functor)

PlutusTx.makeLift ''EscrowParams

-- | The total 'Value' that must be paid into the escrow contract
--   before it can be unlocked
targetTotal :: EscrowParams d -> Value
targetTotal :: EscrowParams d -> Value
targetTotal = (Value -> EscrowTarget d -> Value)
-> Value -> [EscrowTarget d] -> Value
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Value
vl EscrowTarget d
tgt -> Value
vl Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ EscrowTarget d -> Value
forall d. EscrowTarget d -> Value
targetValue EscrowTarget d
tgt) Value
forall a. Monoid a => a
mempty ([EscrowTarget d] -> Value)
-> (EscrowParams d -> [EscrowTarget d]) -> EscrowParams d -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EscrowParams d -> [EscrowTarget d]
forall d. EscrowParams d -> [EscrowTarget d]
escrowTargets

-- | The 'Value' specified by an 'EscrowTarget'
targetValue :: EscrowTarget d -> Value
targetValue :: EscrowTarget d -> Value
targetValue = \case
    PaymentPubKeyTarget PaymentPubKeyHash
_ Value
vl -> Value
vl

-- | Create a 'Ledger.TxOut' value for the target
mkTx :: EscrowTarget Datum -> TxConstraints Action PaymentPubKeyHash
mkTx :: EscrowTarget Datum -> TxConstraints Action PaymentPubKeyHash
mkTx = \case
    PaymentPubKeyTarget PaymentPubKeyHash
pkh Value
vl ->
        PaymentPubKeyHash
-> Value -> TxConstraints Action PaymentPubKeyHash
forall i o. PaymentPubKeyHash -> Value -> TxConstraints i o
Constraints.mustPayToPubKey PaymentPubKeyHash
pkh Value
vl

data Action = Redeem | Refund

data Escrow
instance Scripts.ValidatorTypes Escrow where
    type instance RedeemerType Escrow = Action
    type instance DatumType Escrow = PaymentPubKeyHash

PlutusTx.unstableMakeIsData ''Action
PlutusTx.makeLift ''Action

{-# INLINABLE meetsTarget #-}
-- | @ptx `meetsTarget` tgt@ if @ptx@ pays at least @targetValue tgt@ to the
--   target address.
--
--   The reason why this does not require the target amount to be equal
--   to the actual amount is to enable any excess funds consumed by the
--   spending transaction to be paid to target addresses. This may happen if
--   the target address is also used as a change address for the spending
--   transaction, and allowing the target to be exceed prevents outsiders from
--   poisoning the contract by adding arbitrary outputs to the script address.
meetsTarget :: TxInfo -> EscrowTarget DatumHash -> Bool
meetsTarget :: TxInfo -> EscrowTarget DatumHash -> Bool
meetsTarget TxInfo
ptx = \case
    PaymentPubKeyTarget PaymentPubKeyHash
pkh Value
vl ->
        TxInfo -> PubKeyHash -> Value
valuePaidTo TxInfo
ptx (PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
pkh) Value -> Value -> Bool
`geq` Value
vl

{-# INLINABLE validate #-}
validate :: EscrowParams DatumHash -> PaymentPubKeyHash -> Action -> ScriptContext -> Bool
validate :: EscrowParams DatumHash
-> PaymentPubKeyHash -> Action -> ScriptContext -> Bool
validate EscrowParams{[EscrowTarget DatumHash]
escrowTargets :: [EscrowTarget DatumHash]
escrowTargets :: forall d. EscrowParams d -> [EscrowTarget d]
escrowTargets} PaymentPubKeyHash
contributor Action
action ScriptContext{TxInfo
scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo :: TxInfo
scriptContextTxInfo} =
    case Action
action of
        Action
Redeem ->
            BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"meetsTarget" ((EscrowTarget DatumHash -> Bool)
-> [EscrowTarget DatumHash] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TxInfo -> EscrowTarget DatumHash -> Bool
meetsTarget TxInfo
scriptContextTxInfo) [EscrowTarget DatumHash]
escrowTargets)
        Action
Refund ->
            BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"txSignedBy" (TxInfo
scriptContextTxInfo TxInfo -> PubKeyHash -> Bool
`txSignedBy` PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
contributor)

typedValidator :: EscrowParams Datum -> V2.TypedValidator Escrow
typedValidator :: EscrowParams Datum -> TypedValidator Escrow
typedValidator EscrowParams Datum
escrow = EscrowParams DatumHash -> TypedValidator Escrow
go ((Datum -> DatumHash)
-> EscrowParams Datum -> EscrowParams DatumHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Haskell.fmap Datum -> DatumHash
Ledger.datumHash EscrowParams Datum
escrow) where
    go :: EscrowParams DatumHash -> TypedValidator Escrow
go = CompiledCode (EscrowParams DatumHash -> ValidatorType Escrow)
-> CompiledCode (ValidatorType Escrow -> UntypedValidator)
-> EscrowParams DatumHash
-> TypedValidator Escrow
forall a param.
Lift DefaultUni param =>
CompiledCode (param -> ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> param
-> TypedValidator a
V2.mkTypedValidatorParam @Escrow
        $$(PlutusTx.compile [|| validate ||])
        $$(PlutusTx.compile [|| wrap ||])
    wrap :: (PaymentPubKeyHash -> Action -> ScriptContext -> Bool)
-> UntypedValidator
wrap = (PaymentPubKeyHash -> Action -> ScriptContext -> Bool)
-> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator

escrowContract
    :: EscrowParams Datum
    -> Contract () EscrowSchema EscrowError ()
escrowContract :: EscrowParams Datum -> Contract () EscrowSchema EscrowError ()
escrowContract EscrowParams Datum
escrow =
    let inst :: TypedValidator Escrow
inst = EscrowParams Datum -> TypedValidator Escrow
typedValidator EscrowParams Datum
escrow
        payAndRefund :: Promise
  ()
  ('R
     '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
        "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
        "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
  EscrowError
  RefundSuccess
payAndRefund = forall a w (s :: Row *) e b.
(HasEndpoint "pay-escrow" a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
forall (l :: Symbol) a w (s :: Row *) e b.
(HasEndpoint l a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
endpoint @"pay-escrow" ((Value
  -> Contract
       ()
       ('R
          '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
             "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
             "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
       EscrowError
       RefundSuccess)
 -> Promise
      ()
      ('R
         '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
            "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
            "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
      EscrowError
      RefundSuccess)
-> (Value
    -> Contract
         ()
         ('R
            '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
               "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
               "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
         EscrowError
         RefundSuccess)
-> Promise
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     RefundSuccess
forall a b. (a -> b) -> a -> b
$ \Value
vl -> do
            TxId
_ <- TypedValidator Escrow
-> EscrowParams Datum
-> Value
-> Contract
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     TxId
forall w (s :: Row *) e.
AsContractError e =>
TypedValidator Escrow
-> EscrowParams Datum -> Value -> Contract w s e TxId
pay TypedValidator Escrow
inst EscrowParams Datum
escrow Value
vl
            TypedValidator Escrow
-> EscrowParams Datum
-> Contract
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     RefundSuccess
forall w (s :: Row *).
TypedValidator Escrow
-> EscrowParams Datum -> Contract w s EscrowError RefundSuccess
refund TypedValidator Escrow
inst EscrowParams Datum
escrow
    in [Promise
   ()
   ('R
      '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
         "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
         "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
   EscrowError
   ()]
-> Contract
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     ()
forall w (s :: Row *) e a. [Promise w s e a] -> Contract w s e a
selectList
        [ Promise
  ()
  ('R
     '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
        "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
        "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
  EscrowError
  RefundSuccess
-> Promise
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Promise
  ()
  ('R
     '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
        "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
        "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
  EscrowError
  RefundSuccess
payAndRefund
        , Promise
  ()
  ('R
     '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
        "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
        "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
  EscrowError
  RedeemSuccess
-> Promise
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Promise
   ()
   ('R
      '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
         "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
         "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
   EscrowError
   RedeemSuccess
 -> Promise
      ()
      ('R
         '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
            "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
            "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
      EscrowError
      ())
-> Promise
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     RedeemSuccess
-> Promise
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     ()
forall a b. (a -> b) -> a -> b
$ EscrowParams Datum
-> Promise
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     RedeemSuccess
forall w (s :: Row *) e.
(HasEndpoint "redeem-escrow" () s, AsEscrowError e) =>
EscrowParams Datum -> Promise w s e RedeemSuccess
redeemEp EscrowParams Datum
escrow
        ]

-- | 'pay' with an endpoint that gets the owner's public key and the
--   contribution.
payEp ::
    forall w s e.
    ( HasEndpoint "pay-escrow" Value s
    , AsEscrowError e
    )
    => EscrowParams Datum
    -> Promise w s e TxId
payEp :: EscrowParams Datum -> Promise w s e TxId
payEp EscrowParams Datum
escrow = (Contract w s ContractError TxId -> Contract w s e TxId)
-> Promise w s ContractError TxId -> Promise w s e TxId
forall w1 (s1 :: Row *) e1 a1 w2 (s2 :: Row *) e2 a2.
(Contract w1 s1 e1 a1 -> Contract w2 s2 e2 a2)
-> Promise w1 s1 e1 a1 -> Promise w2 s2 e2 a2
promiseMap
    ((ContractError -> e)
-> Contract w s ContractError TxId -> Contract w s e TxId
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e ContractError -> ContractError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e ContractError
forall r. AsEscrowError r => Prism' r ContractError
_EContractError))
    (forall a w (s :: Row *) e b.
(HasEndpoint "pay-escrow" a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
forall (l :: Symbol) a w (s :: Row *) e b.
(HasEndpoint l a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
endpoint @"pay-escrow" ((Value -> Contract w s ContractError TxId)
 -> Promise w s ContractError TxId)
-> (Value -> Contract w s ContractError TxId)
-> Promise w s ContractError TxId
forall a b. (a -> b) -> a -> b
$ TypedValidator Escrow
-> EscrowParams Datum -> Value -> Contract w s ContractError TxId
forall w (s :: Row *) e.
AsContractError e =>
TypedValidator Escrow
-> EscrowParams Datum -> Value -> Contract w s e TxId
pay (EscrowParams Datum -> TypedValidator Escrow
typedValidator EscrowParams Datum
escrow) EscrowParams Datum
escrow)

-- | Pay some money into the escrow contract.
pay ::
    forall w s e.
    ( AsContractError e
    )
    => TypedValidator Escrow
    -- ^ The instance
    -> EscrowParams Datum
    -- ^ The escrow contract
    -> Value
    -- ^ How much money to pay in
    -> Contract w s e TxId
pay :: TypedValidator Escrow
-> EscrowParams Datum -> Value -> Contract w s e TxId
pay TypedValidator Escrow
inst EscrowParams Datum
_escrow Value
vl = do
    PaymentPubKeyHash
pk <- Contract w s e PaymentPubKeyHash
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e PaymentPubKeyHash
ownFirstPaymentPubKeyHash
    let tx :: TxConstraints Action PaymentPubKeyHash
tx = PaymentPubKeyHash
-> Value -> TxConstraints Action PaymentPubKeyHash
forall o i. o -> Value -> TxConstraints i o
Constraints.mustPayToTheScriptWithDatumInTx PaymentPubKeyHash
pk Value
vl
    UnbalancedTx
utx <- ScriptLookups Escrow
-> TxConstraints (RedeemerType Escrow) (DatumType Escrow)
-> Contract w s e UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints (TypedValidator Escrow -> ScriptLookups Escrow
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator Escrow
inst) TxConstraints (RedeemerType Escrow) (DatumType Escrow)
TxConstraints Action PaymentPubKeyHash
tx Contract w s e UnbalancedTx
-> (UnbalancedTx -> Contract w s e UnbalancedTx)
-> Contract w s e UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s e UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx
    CardanoTx -> TxId
getCardanoTxId (CardanoTx -> TxId)
-> Contract w s e CardanoTx -> Contract w s e TxId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnbalancedTx -> Contract w s e CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx UnbalancedTx
utx

newtype RedeemSuccess = RedeemSuccess TxId
    deriving (RedeemSuccess -> RedeemSuccess -> Bool
(RedeemSuccess -> RedeemSuccess -> Bool)
-> (RedeemSuccess -> RedeemSuccess -> Bool) -> Eq RedeemSuccess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RedeemSuccess -> RedeemSuccess -> Bool
$c/= :: RedeemSuccess -> RedeemSuccess -> Bool
== :: RedeemSuccess -> RedeemSuccess -> Bool
$c== :: RedeemSuccess -> RedeemSuccess -> Bool
Haskell.Eq, Int -> RedeemSuccess -> ShowS
[RedeemSuccess] -> ShowS
RedeemSuccess -> String
(Int -> RedeemSuccess -> ShowS)
-> (RedeemSuccess -> String)
-> ([RedeemSuccess] -> ShowS)
-> Show RedeemSuccess
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedeemSuccess] -> ShowS
$cshowList :: [RedeemSuccess] -> ShowS
show :: RedeemSuccess -> String
$cshow :: RedeemSuccess -> String
showsPrec :: Int -> RedeemSuccess -> ShowS
$cshowsPrec :: Int -> RedeemSuccess -> ShowS
Haskell.Show)

-- | 'redeem' with an endpoint.
redeemEp ::
    forall w s e.
    ( HasEndpoint "redeem-escrow" () s
    , AsEscrowError e
    )
    => EscrowParams Datum
    -> Promise w s e RedeemSuccess
redeemEp :: EscrowParams Datum -> Promise w s e RedeemSuccess
redeemEp EscrowParams Datum
escrow = (Contract w s EscrowError RedeemSuccess
 -> Contract w s e RedeemSuccess)
-> Promise w s EscrowError RedeemSuccess
-> Promise w s e RedeemSuccess
forall w1 (s1 :: Row *) e1 a1 w2 (s2 :: Row *) e2 a2.
(Contract w1 s1 e1 a1 -> Contract w2 s2 e2 a2)
-> Promise w1 s1 e1 a1 -> Promise w2 s2 e2 a2
promiseMap
    ((EscrowError -> e)
-> Contract w s EscrowError RedeemSuccess
-> Contract w s e RedeemSuccess
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e EscrowError -> EscrowError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e EscrowError
forall r. AsEscrowError r => Prism' r EscrowError
_EscrowError))
    (forall a w (s :: Row *) e b.
(HasEndpoint "redeem-escrow" a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
forall (l :: Symbol) a w (s :: Row *) e b.
(HasEndpoint l a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
endpoint @"redeem-escrow" ((() -> Contract w s EscrowError RedeemSuccess)
 -> Promise w s EscrowError RedeemSuccess)
-> (() -> Contract w s EscrowError RedeemSuccess)
-> Promise w s EscrowError RedeemSuccess
forall a b. (a -> b) -> a -> b
$ \() -> TypedValidator Escrow
-> EscrowParams Datum -> Contract w s EscrowError RedeemSuccess
forall w (s :: Row *) e.
AsEscrowError e =>
TypedValidator Escrow
-> EscrowParams Datum -> Contract w s e RedeemSuccess
redeem (EscrowParams Datum -> TypedValidator Escrow
typedValidator EscrowParams Datum
escrow) EscrowParams Datum
escrow)

-- | Redeem all outputs at the contract address using a transaction that
--   has all the outputs defined in the contract's list of targets.
redeem ::
    forall w s e.
    ( AsEscrowError e
    )
    => TypedValidator Escrow
    -> EscrowParams Datum
    -> Contract w s e RedeemSuccess
redeem :: TypedValidator Escrow
-> EscrowParams Datum -> Contract w s e RedeemSuccess
redeem TypedValidator Escrow
inst EscrowParams Datum
escrow = (EscrowError -> e)
-> Contract w s EscrowError RedeemSuccess
-> Contract w s e RedeemSuccess
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e EscrowError -> EscrowError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e EscrowError
forall r. AsEscrowError r => Prism' r EscrowError
_EscrowError) (Contract w s EscrowError RedeemSuccess
 -> Contract w s e RedeemSuccess)
-> Contract w s EscrowError RedeemSuccess
-> Contract w s e RedeemSuccess
forall a b. (a -> b) -> a -> b
$ do
    NetworkId
networkId <- Params -> NetworkId
Params.pNetworkId (Params -> NetworkId)
-> Contract w s EscrowError Params
-> Contract w s EscrowError NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract w s EscrowError Params
forall w (s :: Row *) e. AsContractError e => Contract w s e Params
getParams
    let addr :: AddressInEra BabbageEra
addr = NetworkId -> TypedValidator Escrow -> AddressInEra BabbageEra
forall a. NetworkId -> TypedValidator a -> AddressInEra BabbageEra
Scripts.validatorCardanoAddress NetworkId
networkId TypedValidator Escrow
inst
    Map TxOutRef DecoratedTxOut
unspentOutputs <- AddressInEra BabbageEra
-> Contract w s EscrowError (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
AddressInEra BabbageEra
-> Contract w s e (Map TxOutRef DecoratedTxOut)
utxosAt AddressInEra BabbageEra
addr
    let
        tx :: TxConstraints Action PaymentPubKeyHash
tx = Map TxOutRef DecoratedTxOut
-> Action -> TxConstraints Action PaymentPubKeyHash
forall i o. Map TxOutRef DecoratedTxOut -> i -> TxConstraints i o
Constraints.spendUtxosFromTheScript Map TxOutRef DecoratedTxOut
unspentOutputs Action
Redeem
                TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> (EscrowTarget Datum -> TxConstraints Action PaymentPubKeyHash)
-> [EscrowTarget Datum] -> TxConstraints Action PaymentPubKeyHash
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap EscrowTarget Datum -> TxConstraints Action PaymentPubKeyHash
mkTx (EscrowParams Datum -> [EscrowTarget Datum]
forall d. EscrowParams d -> [EscrowTarget d]
escrowTargets EscrowParams Datum
escrow)
    if (DecoratedTxOut -> Value) -> Map TxOutRef DecoratedTxOut -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DecoratedTxOut -> Value
Tx.decoratedTxOutPlutusValue Map TxOutRef DecoratedTxOut
unspentOutputs Value -> Value -> Bool
`lt` EscrowParams Datum -> Value
forall d. EscrowParams d -> Value
targetTotal EscrowParams Datum
escrow
       then AReview EscrowError RedeemFailReason
-> RedeemFailReason -> Contract w s EscrowError RedeemSuccess
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview EscrowError RedeemFailReason
forall r. AsEscrowError r => Prism' r RedeemFailReason
_RedeemFailed RedeemFailReason
NotEnoughFundsAtAddress
       else do
         UnbalancedTx
utx <- ScriptLookups Escrow
-> TxConstraints (RedeemerType Escrow) (DatumType Escrow)
-> Contract w s EscrowError UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints ( TypedValidator Escrow -> ScriptLookups Escrow
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator Escrow
inst
                               ScriptLookups Escrow
-> ScriptLookups Escrow -> ScriptLookups Escrow
forall a. Semigroup a => a -> a -> a
<> Map TxOutRef DecoratedTxOut -> ScriptLookups Escrow
forall a. Map TxOutRef DecoratedTxOut -> ScriptLookups a
Constraints.unspentOutputs Map TxOutRef DecoratedTxOut
unspentOutputs
                                ) TxConstraints (RedeemerType Escrow) (DatumType Escrow)
TxConstraints Action PaymentPubKeyHash
tx Contract w s EscrowError UnbalancedTx
-> (UnbalancedTx -> Contract w s EscrowError UnbalancedTx)
-> Contract w s EscrowError UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s EscrowError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx
         TxId -> RedeemSuccess
RedeemSuccess (TxId -> RedeemSuccess)
-> (CardanoTx -> TxId) -> CardanoTx -> RedeemSuccess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> TxId
getCardanoTxId (CardanoTx -> RedeemSuccess)
-> Contract w s EscrowError CardanoTx
-> Contract w s EscrowError RedeemSuccess
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnbalancedTx -> Contract w s EscrowError CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx UnbalancedTx
utx

newtype RefundSuccess = RefundSuccess TxId
    deriving newtype (RefundSuccess -> RefundSuccess -> Bool
(RefundSuccess -> RefundSuccess -> Bool)
-> (RefundSuccess -> RefundSuccess -> Bool) -> Eq RefundSuccess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RefundSuccess -> RefundSuccess -> Bool
$c/= :: RefundSuccess -> RefundSuccess -> Bool
== :: RefundSuccess -> RefundSuccess -> Bool
$c== :: RefundSuccess -> RefundSuccess -> Bool
Haskell.Eq, Int -> RefundSuccess -> ShowS
[RefundSuccess] -> ShowS
RefundSuccess -> String
(Int -> RefundSuccess -> ShowS)
-> (RefundSuccess -> String)
-> ([RefundSuccess] -> ShowS)
-> Show RefundSuccess
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RefundSuccess] -> ShowS
$cshowList :: [RefundSuccess] -> ShowS
show :: RefundSuccess -> String
$cshow :: RefundSuccess -> String
showsPrec :: Int -> RefundSuccess -> ShowS
$cshowsPrec :: Int -> RefundSuccess -> ShowS
Haskell.Show, Rep RefundSuccess x -> RefundSuccess
RefundSuccess -> Rep RefundSuccess x
(forall x. RefundSuccess -> Rep RefundSuccess x)
-> (forall x. Rep RefundSuccess x -> RefundSuccess)
-> Generic RefundSuccess
forall x. Rep RefundSuccess x -> RefundSuccess
forall x. RefundSuccess -> Rep RefundSuccess x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
to :: Rep RefundSuccess x -> RefundSuccess
$cto :: forall x. Rep RefundSuccess x -> RefundSuccess
from :: RefundSuccess -> Rep RefundSuccess x
$cfrom :: forall x. RefundSuccess -> Rep RefundSuccess x
Generic)
    deriving anyclass ([RefundSuccess] -> Encoding
[RefundSuccess] -> Value
RefundSuccess -> Encoding
RefundSuccess -> Value
(RefundSuccess -> Value)
-> (RefundSuccess -> Encoding)
-> ([RefundSuccess] -> Value)
-> ([RefundSuccess] -> Encoding)
-> ToJSON RefundSuccess
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RefundSuccess] -> Encoding
$ctoEncodingList :: [RefundSuccess] -> Encoding
toJSONList :: [RefundSuccess] -> Value
$ctoJSONList :: [RefundSuccess] -> Value
toEncoding :: RefundSuccess -> Encoding
$ctoEncoding :: RefundSuccess -> Encoding
toJSON :: RefundSuccess -> Value
$ctoJSON :: RefundSuccess -> Value
ToJSON, Value -> Parser [RefundSuccess]
Value -> Parser RefundSuccess
(Value -> Parser RefundSuccess)
-> (Value -> Parser [RefundSuccess]) -> FromJSON RefundSuccess
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RefundSuccess]
$cparseJSONList :: Value -> Parser [RefundSuccess]
parseJSON :: Value -> Parser RefundSuccess
$cparseJSON :: Value -> Parser RefundSuccess
FromJSON)

-- | 'refund' with an endpoint.
refundEp ::
    forall w s.
    ( HasEndpoint "refund-escrow" () s
    )
    => EscrowParams Datum
    -> Promise w s EscrowError RefundSuccess
refundEp :: EscrowParams Datum -> Promise w s EscrowError RefundSuccess
refundEp EscrowParams Datum
escrow = forall a w (s :: Row *) e b.
(HasEndpoint "refund-escrow" a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
forall (l :: Symbol) a w (s :: Row *) e b.
(HasEndpoint l a s, AsContractError e, FromJSON a) =>
(a -> Contract w s e b) -> Promise w s e b
endpoint @"refund-escrow" ((() -> Contract w s EscrowError RefundSuccess)
 -> Promise w s EscrowError RefundSuccess)
-> (() -> Contract w s EscrowError RefundSuccess)
-> Promise w s EscrowError RefundSuccess
forall a b. (a -> b) -> a -> b
$ \() -> TypedValidator Escrow
-> EscrowParams Datum -> Contract w s EscrowError RefundSuccess
forall w (s :: Row *).
TypedValidator Escrow
-> EscrowParams Datum -> Contract w s EscrowError RefundSuccess
refund (EscrowParams Datum -> TypedValidator Escrow
typedValidator EscrowParams Datum
escrow) EscrowParams Datum
escrow

-- | Claim a refund of the contribution.
refund ::
    forall w s.
    TypedValidator Escrow
    -> EscrowParams Datum
    -> Contract w s EscrowError RefundSuccess
refund :: TypedValidator Escrow
-> EscrowParams Datum -> Contract w s EscrowError RefundSuccess
refund TypedValidator Escrow
inst EscrowParams Datum
_escrow = do
    NetworkId
networkId <- Params -> NetworkId
Params.pNetworkId (Params -> NetworkId)
-> Contract w s EscrowError Params
-> Contract w s EscrowError NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract w s EscrowError Params
forall w (s :: Row *) e. AsContractError e => Contract w s e Params
getParams
    PaymentPubKeyHash
pk <- Contract w s EscrowError PaymentPubKeyHash
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e PaymentPubKeyHash
ownFirstPaymentPubKeyHash
    Map TxOutRef DecoratedTxOut
unspentOutputs <- AddressInEra BabbageEra
-> Contract w s EscrowError (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
AddressInEra BabbageEra
-> Contract w s e (Map TxOutRef DecoratedTxOut)
utxosAt (NetworkId -> TypedValidator Escrow -> AddressInEra BabbageEra
forall a. NetworkId -> TypedValidator a -> AddressInEra BabbageEra
Scripts.validatorCardanoAddress NetworkId
networkId TypedValidator Escrow
inst)
    let pkh :: DatumHash
pkh = Datum -> DatumHash
Ledger.datumHash (Datum -> DatumHash) -> Datum -> DatumHash
forall a b. (a -> b) -> a -> b
$ BuiltinData -> Datum
Datum (BuiltinData -> Datum) -> BuiltinData -> Datum
forall a b. (a -> b) -> a -> b
$ PaymentPubKeyHash -> BuiltinData
forall a. ToData a => a -> BuiltinData
PlutusTx.toBuiltinData PaymentPubKeyHash
pk
        flt :: TxOutRef -> DecoratedTxOut -> Bool
flt TxOutRef
_ DecoratedTxOut
ciTxOut = Getting Any DecoratedTxOut () -> DecoratedTxOut -> Bool
forall s a. Getting Any s a -> s -> Bool
has (((DatumHash, DatumFromQuery)
 -> Const Any (DatumHash, DatumFromQuery))
-> DecoratedTxOut -> Const Any DecoratedTxOut
Traversal' DecoratedTxOut (DatumHash, DatumFromQuery)
Tx.decoratedTxOutScriptDatum (((DatumHash, DatumFromQuery)
  -> Const Any (DatumHash, DatumFromQuery))
 -> DecoratedTxOut -> Const Any DecoratedTxOut)
-> ((() -> Const Any ())
    -> (DatumHash, DatumFromQuery)
    -> Const Any (DatumHash, DatumFromQuery))
-> Getting Any DecoratedTxOut ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DatumHash -> Const Any DatumHash)
-> (DatumHash, DatumFromQuery)
-> Const Any (DatumHash, DatumFromQuery)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((DatumHash -> Const Any DatumHash)
 -> (DatumHash, DatumFromQuery)
 -> Const Any (DatumHash, DatumFromQuery))
-> ((() -> Const Any ()) -> DatumHash -> Const Any DatumHash)
-> (() -> Const Any ())
-> (DatumHash, DatumFromQuery)
-> Const Any (DatumHash, DatumFromQuery)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatumHash -> Prism' DatumHash ()
forall a. Eq a => a -> Prism' a ()
only DatumHash
pkh) DecoratedTxOut
ciTxOut
        tx' :: TxConstraints Action PaymentPubKeyHash
tx' = (TxOutRef -> DecoratedTxOut -> Bool)
-> Map TxOutRef DecoratedTxOut
-> Action
-> TxConstraints Action PaymentPubKeyHash
forall i o.
(TxOutRef -> DecoratedTxOut -> Bool)
-> Map TxOutRef DecoratedTxOut -> i -> TxConstraints i o
Constraints.spendUtxosFromTheScriptFilter TxOutRef -> DecoratedTxOut -> Bool
flt Map TxOutRef DecoratedTxOut
unspentOutputs Action
Refund
    if TxConstraints Action PaymentPubKeyHash -> Bool
forall i o. TxConstraints i o -> Bool
Constraints.modifiesUtxoSet TxConstraints Action PaymentPubKeyHash
tx'
    then do
        UnbalancedTx
utx <- ScriptLookups Escrow
-> TxConstraints (RedeemerType Escrow) (DatumType Escrow)
-> Contract w s EscrowError UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints ( TypedValidator Escrow -> ScriptLookups Escrow
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator Escrow
inst
                              ScriptLookups Escrow
-> ScriptLookups Escrow -> ScriptLookups Escrow
forall a. Semigroup a => a -> a -> a
<> Map TxOutRef DecoratedTxOut -> ScriptLookups Escrow
forall a. Map TxOutRef DecoratedTxOut -> ScriptLookups a
Constraints.unspentOutputs Map TxOutRef DecoratedTxOut
unspentOutputs
                               ) TxConstraints (RedeemerType Escrow) (DatumType Escrow)
TxConstraints Action PaymentPubKeyHash
tx' Contract w s EscrowError UnbalancedTx
-> (UnbalancedTx -> Contract w s EscrowError UnbalancedTx)
-> Contract w s EscrowError UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s EscrowError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx
        TxId -> RefundSuccess
RefundSuccess (TxId -> RefundSuccess)
-> (CardanoTx -> TxId) -> CardanoTx -> RefundSuccess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> TxId
getCardanoTxId (CardanoTx -> RefundSuccess)
-> Contract w s EscrowError CardanoTx
-> Contract w s EscrowError RefundSuccess
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnbalancedTx -> Contract w s EscrowError CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx UnbalancedTx
utx
    else AReview EscrowError ()
-> () -> Contract w s EscrowError RefundSuccess
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview EscrowError ()
forall r. AsEscrowError r => Prism' r ()
_RefundFailed ()

covIdx :: CoverageIndex
covIdx :: CoverageIndex
covIdx = CompiledCode
  (EscrowParams DatumHash
   -> PaymentPubKeyHash -> Action -> ScriptContext -> Bool)
-> CoverageIndex
forall (uni :: * -> *) fun a.
CompiledCodeIn uni fun a -> CoverageIndex
getCovIdx $$(PlutusTx.compile [|| validate ||])
      CoverageIndex -> CoverageIndex -> CoverageIndex
forall a. Semigroup a => a -> a -> a
<> CompiledCode
  ((PaymentPubKeyHash -> Action -> ScriptContext -> Bool)
   -> UntypedValidator)
-> CoverageIndex
forall (uni :: * -> *) fun a.
CompiledCodeIn uni fun a -> CoverageIndex
getCovIdx $$(PlutusTx.compile [|| wrap ||])
  where
    wrap :: (PaymentPubKeyHash -> Action -> ScriptContext -> Bool) ->
            Scripts.UntypedValidator
    wrap :: (PaymentPubKeyHash -> Action -> ScriptContext -> Bool)
-> UntypedValidator
wrap = (PaymentPubKeyHash -> Action -> ScriptContext -> Bool)
-> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator