{-# 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.Escrow(
    -- $escrow
    Escrow
    , EscrowError(..)
    , AsEscrowError(..)
    , EscrowParams(..)
    , EscrowTarget(..)
    , payToScriptTarget
    , payToPaymentPubKeyTarget
    , targetTotal
    , escrowContract
    , payRedeemRefund
    , 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 PlutusTx qualified
import PlutusTx.Code
import PlutusTx.Coverage
import PlutusTx.Prelude hiding (Applicative (..), Semigroup (..), check, foldMap)

import Cardano.Node.Emulator.Internal.Node (pNetworkId)
import Ledger (POSIXTime, PaymentPubKeyHash (unPaymentPubKeyHash), TxId, getCardanoTxId)
import Ledger qualified
import Ledger.Interval (after, before)
import Ledger.Tx qualified as Tx
import Ledger.Tx.Constraints (TxConstraints)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Tx.Constraints.ValidityInterval qualified as Interval
import Ledger.Typed.Scripts (TypedValidator)
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.Contract
import Plutus.Script.Utils.Scripts (datumHash)
import Plutus.Script.Utils.V2.Contexts (ScriptContext (..), TxInfo (..), scriptOutputsAt, txInfoValidRange, 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, ValidatorHash)
import Plutus.V2.Ledger.Contexts (valuePaidTo)
import Plutus.V2.Ledger.Tx (OutputDatum (OutputDatumHash))

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

-- $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
    | ScriptTarget ValidatorHash d Value
    deriving (a -> EscrowTarget b -> EscrowTarget a
(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

-- | An 'EscrowTarget' that pays the value to a script address, with the
--   given data script.
payToScriptTarget :: ValidatorHash -> Datum -> Value -> EscrowTarget Datum
payToScriptTarget :: ValidatorHash -> Datum -> Value -> EscrowTarget Datum
payToScriptTarget = ValidatorHash -> Datum -> Value -> EscrowTarget Datum
forall d. ValidatorHash -> d -> Value -> EscrowTarget d
ScriptTarget

-- | Definition of an escrow contract, consisting of a deadline and a list of targets
data EscrowParams d =
    EscrowParams
        { EscrowParams d -> POSIXTime
escrowDeadline :: POSIXTime
        -- ^ Latest point at which the outputs may be spent.
        , 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 -> EscrowParams b -> EscrowParams a
(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
Haskell.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
    ScriptTarget ValidatorHash
_ d
_ 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
    ScriptTarget ValidatorHash
vs Datum
ds Value
vl ->
        ValidatorHash
-> Datum -> Value -> TxConstraints Action PaymentPubKeyHash
forall i o. ValidatorHash -> Datum -> Value -> TxConstraints i o
Constraints.mustPayToOtherScriptWithDatumInTx ValidatorHash
vs Datum
ds Value
vl
        TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> Datum -> TxConstraints Action PaymentPubKeyHash
forall i o. Datum -> TxConstraints i o
Constraints.mustIncludeDatumInTx Datum
ds

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
    ScriptTarget ValidatorHash
validatorHash DatumHash
dataValue Value
vl ->
        case ValidatorHash -> TxInfo -> [(OutputDatum, Value)]
scriptOutputsAt ValidatorHash
validatorHash TxInfo
ptx of
            [(OutputDatum
dataValue', Value
vl')] ->
                BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"dataValue" (OutputDatum
dataValue' OutputDatum -> OutputDatum -> Bool
forall a. Eq a => a -> a -> Bool
== (DatumHash -> OutputDatum
OutputDatumHash DatumHash
dataValue))
                Bool -> Bool -> Bool
&& BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"value" (Value
vl' Value -> Value -> Bool
`geq` Value
vl)
            [(OutputDatum, Value)]
_ -> Bool
False

{-# INLINABLE validate #-}
validate :: EscrowParams DatumHash -> PaymentPubKeyHash -> Action -> ScriptContext -> Bool
validate :: EscrowParams DatumHash
-> PaymentPubKeyHash -> Action -> ScriptContext -> Bool
validate EscrowParams{POSIXTime
escrowDeadline :: POSIXTime
escrowDeadline :: forall d. EscrowParams d -> POSIXTime
escrowDeadline, [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
"escrowDeadline-after" (POSIXTime
escrowDeadline POSIXTime -> Interval POSIXTime -> Bool
forall a. Ord a => a -> Interval a -> Bool
`after` TxInfo -> Interval POSIXTime
txInfoValidRange TxInfo
scriptContextTxInfo)
            Bool -> Bool -> Bool
&& 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
"escrowDeadline-before" ((POSIXTime
escrowDeadline POSIXTime -> POSIXTime -> POSIXTime
forall a. AdditiveGroup a => a -> a -> a
- POSIXTime
1) POSIXTime -> Interval POSIXTime -> Bool
forall a. Ord a => a -> Interval a -> Bool
`before` TxInfo -> Interval POSIXTime
txInfoValidRange TxInfo
scriptContextTxInfo)
            Bool -> Bool -> Bool
&& 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
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
            POSIXTime
_ <- POSIXTime
-> Contract
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     POSIXTime
forall w (s :: Row *) e.
AsContractError e =>
POSIXTime -> Contract w s e POSIXTime
awaitTime (POSIXTime
 -> Contract
      ()
      ('R
         '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
            "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
            "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
      EscrowError
      POSIXTime)
-> POSIXTime
-> Contract
     ()
     ('R
        '[ "pay-escrow" ':-> (EndpointValue Value, ActiveEndpoint),
           "redeem-escrow" ':-> (EndpointValue (), ActiveEndpoint),
           "refund-escrow" ':-> (EndpointValue (), ActiveEndpoint)])
     EscrowError
     POSIXTime
forall a b. (a -> b) -> a -> b
$ EscrowParams Datum -> POSIXTime
forall d. EscrowParams d -> POSIXTime
escrowDeadline EscrowParams Datum
escrow
            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
          TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime
-> TxConstraints Action PaymentPubKeyHash
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange (POSIXTime -> POSIXTime -> ValidityInterval POSIXTime
forall a. a -> a -> ValidityInterval a
Interval.interval POSIXTime
1 (POSIXTime
1 POSIXTime -> POSIXTime -> POSIXTime
forall a. AdditiveSemigroup a => a -> a -> a
+ EscrowParams Datum -> POSIXTime
forall d. EscrowParams d -> POSIXTime
escrowDeadline EscrowParams Datum
escrow))
    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
        Contract w s e UnbalancedTx
-> (UnbalancedTx -> Contract w s e CardanoTx)
-> Contract w s e CardanoTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s e CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx
        Contract w s e CardanoTx
-> (CardanoTx -> Contract w s e TxId) -> Contract w s e TxId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TxId -> Contract w s e TxId
forall (m :: * -> *) a. Monad m => a -> m a
return (TxId -> Contract w s e TxId)
-> (CardanoTx -> TxId) -> CardanoTx -> Contract w s e TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> TxId
getCardanoTxId

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
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
    POSIXTime
current <- (POSIXTime, POSIXTime) -> POSIXTime
forall a b. (a, b) -> b
snd ((POSIXTime, POSIXTime) -> POSIXTime)
-> Contract w s EscrowError (POSIXTime, POSIXTime)
-> Contract w s EscrowError POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract w s EscrowError (POSIXTime, POSIXTime)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (POSIXTime, POSIXTime)
currentNodeClientTimeRange
    if POSIXTime
current POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
>= EscrowParams Datum -> POSIXTime
forall d. EscrowParams d -> POSIXTime
escrowDeadline 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
DeadlinePassed
    else 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
      let
          validityTimeRange :: ValidityInterval POSIXTime
validityTimeRange = POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
Interval.lessThan (POSIXTime -> ValidityInterval POSIXTime)
-> POSIXTime -> ValidityInterval POSIXTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> POSIXTime
forall a. Enum a => a -> a
Haskell.pred (POSIXTime -> POSIXTime) -> POSIXTime -> POSIXTime
forall a b. (a -> b) -> a -> b
$ EscrowParams Datum -> POSIXTime
forall d. EscrowParams d -> POSIXTime
escrowDeadline EscrowParams Datum
escrow
          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)
                  TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime
-> TxConstraints Action PaymentPubKeyHash
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange ValidityInterval POSIXTime
validityTimeRange
      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
      UnbalancedTx
adjusted <- UnbalancedTx -> Contract w s EscrowError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx UnbalancedTx
utx
      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
adjusted

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
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
    PaymentPubKeyHash
pk <- Contract w s EscrowError PaymentPubKeyHash
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e PaymentPubKeyHash
ownFirstPaymentPubKeyHash
    let pkh :: DatumHash
pkh = Datum -> DatumHash
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
    let 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
                TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> PaymentPubKeyHash -> TxConstraints Action PaymentPubKeyHash
forall i o. PaymentPubKeyHash -> TxConstraints i o
Constraints.mustBeSignedBy PaymentPubKeyHash
pk
                TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
-> TxConstraints Action PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime
-> TxConstraints Action PaymentPubKeyHash
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange (POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
Interval.from (POSIXTime -> ValidityInterval POSIXTime)
-> POSIXTime -> ValidityInterval POSIXTime
forall a b. (a -> b) -> a -> b
$ EscrowParams Datum -> POSIXTime
forall d. EscrowParams d -> POSIXTime
escrowDeadline EscrowParams Datum
escrow)
    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'
        UnbalancedTx
adjusted <- UnbalancedTx -> Contract w s EscrowError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx UnbalancedTx
utx
        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
adjusted
    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 ()

-- | Pay some money into the escrow contract. Then release all funds to their
--   specified targets if enough funds were deposited before the deadline,
--   or reclaim the contribution if the goal has not been met.
payRedeemRefund ::
    forall w s.
    EscrowParams Datum
    -> Value
    -> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
payRedeemRefund :: EscrowParams Datum
-> Value
-> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
payRedeemRefund EscrowParams Datum
params Value
vl = do
    let inst :: TypedValidator Escrow
inst = EscrowParams Datum -> TypedValidator Escrow
typedValidator EscrowParams Datum
params
        go :: Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
go = do
            NetworkId
networkId <- Params -> NetworkId
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
            Map TxOutRef DecoratedTxOut
cur <- 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 presentVal :: Value
presentVal = (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
cur
            if Value
presentVal Value -> Value -> Bool
`geq` EscrowParams Datum -> Value
forall d. EscrowParams d -> Value
targetTotal EscrowParams Datum
params
                then RedeemSuccess -> Either RefundSuccess RedeemSuccess
forall a b. b -> Either a b
Right (RedeemSuccess -> Either RefundSuccess RedeemSuccess)
-> Contract w s EscrowError RedeemSuccess
-> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 TypedValidator Escrow
inst EscrowParams Datum
params
                else do
                    POSIXTime
time <- (POSIXTime, POSIXTime) -> POSIXTime
forall a b. (a, b) -> b
snd ((POSIXTime, POSIXTime) -> POSIXTime)
-> Contract w s EscrowError (POSIXTime, POSIXTime)
-> Contract w s EscrowError POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract w s EscrowError (POSIXTime, POSIXTime)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (POSIXTime, POSIXTime)
currentNodeClientTimeRange
                    if POSIXTime
time POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
>= EscrowParams Datum -> POSIXTime
forall d. EscrowParams d -> POSIXTime
escrowDeadline EscrowParams Datum
params
                        then RefundSuccess -> Either RefundSuccess RedeemSuccess
forall a b. a -> Either a b
Left (RefundSuccess -> Either RefundSuccess RedeemSuccess)
-> Contract w s EscrowError RefundSuccess
-> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypedValidator Escrow
-> EscrowParams Datum -> Contract w s EscrowError RefundSuccess
forall w (s :: Row *).
TypedValidator Escrow
-> EscrowParams Datum -> Contract w s EscrowError RefundSuccess
refund TypedValidator Escrow
inst EscrowParams Datum
params
                        else Natural -> Contract w s EscrowError Slot
forall w (s :: Row *) e.
AsContractError e =>
Natural -> Contract w s e Slot
waitNSlots Natural
1 Contract w s EscrowError Slot
-> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
-> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
go
    -- Pay the value 'vl' into the contract
    TxId
_ <- TypedValidator Escrow
-> EscrowParams Datum -> Value -> Contract w s 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
params Value
vl
    Contract w s EscrowError (Either RefundSuccess RedeemSuccess)
go

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 ||])