{-# 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 -fplugin-opt Language.PlutusTx.Plugin:debug-context #-}

-- | This simple escrow contract facilitiates and exchange of currencies.
module Plutus.Contracts.SimpleEscrow
  where

import Cardano.Node.Emulator.Internal.Node.Params qualified as Params
import Control.Lens (makeClassyPrisms)
import Control.Monad (void)
import Control.Monad.Error.Lens (throwing)
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)

import Ledger (POSIXTime, PaymentPubKeyHash (unPaymentPubKeyHash), TxId, getCardanoTxId)
import Ledger qualified
import Ledger.Interval (after, before)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Tx.Constraints.ValidityInterval qualified as Interval
import Ledger.Typed.Scripts (ScriptContextV2)
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.Script.Utils.Value (Value, geq)
import Plutus.V2.Ledger.Api (txInfoValidRange)
import Plutus.V2.Ledger.Contexts (txSignedBy, valuePaidTo)
import Plutus.V2.Ledger.Contexts qualified as V2

import Plutus.Contract
import PlutusTx qualified
import PlutusTx.Prelude hiding (Applicative (..), Semigroup (..), check, foldMap)

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

data EscrowParams =
  EscrowParams
    { EscrowParams -> PaymentPubKeyHash
payee     :: PaymentPubKeyHash
    -- ^ The entity that needs to be paid the 'expecting' 'Value'.
    , EscrowParams -> Value
paying    :: Value
    -- ^ Value to be paid out to the redeemer.
    , EscrowParams -> Value
expecting :: Value
    -- ^ Value to be received by the payee.
    , EscrowParams -> POSIXTime
deadline  :: POSIXTime
    -- ^ Time after which the contract expires.
    }
    deriving stock (Int -> EscrowParams -> ShowS
[EscrowParams] -> ShowS
EscrowParams -> String
(Int -> EscrowParams -> ShowS)
-> (EscrowParams -> String)
-> ([EscrowParams] -> ShowS)
-> Show EscrowParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EscrowParams] -> ShowS
$cshowList :: [EscrowParams] -> ShowS
show :: EscrowParams -> String
$cshow :: EscrowParams -> String
showsPrec :: Int -> EscrowParams -> ShowS
$cshowsPrec :: Int -> EscrowParams -> ShowS
Haskell.Show, (forall x. EscrowParams -> Rep EscrowParams x)
-> (forall x. Rep EscrowParams x -> EscrowParams)
-> Generic EscrowParams
forall x. Rep EscrowParams x -> EscrowParams
forall x. EscrowParams -> Rep EscrowParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EscrowParams x -> EscrowParams
$cfrom :: forall x. EscrowParams -> Rep EscrowParams x
Generic)
    deriving anyclass ([EscrowParams] -> Encoding
[EscrowParams] -> Value
EscrowParams -> Encoding
EscrowParams -> Value
(EscrowParams -> Value)
-> (EscrowParams -> Encoding)
-> ([EscrowParams] -> Value)
-> ([EscrowParams] -> Encoding)
-> ToJSON EscrowParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [EscrowParams] -> Encoding
$ctoEncodingList :: [EscrowParams] -> Encoding
toJSONList :: [EscrowParams] -> Value
$ctoJSONList :: [EscrowParams] -> Value
toEncoding :: EscrowParams -> Encoding
$ctoEncoding :: EscrowParams -> Encoding
toJSON :: EscrowParams -> Value
$ctoJSON :: EscrowParams -> Value
ToJSON, Value -> Parser [EscrowParams]
Value -> Parser EscrowParams
(Value -> Parser EscrowParams)
-> (Value -> Parser [EscrowParams]) -> FromJSON EscrowParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [EscrowParams]
$cparseJSONList :: Value -> Parser [EscrowParams]
parseJSON :: Value -> Parser EscrowParams
$cparseJSON :: Value -> Parser EscrowParams
FromJSON)

type EscrowSchema =
        Endpoint "lock"   EscrowParams
        .\/ Endpoint "refund" EscrowParams
        .\/ Endpoint "redeem" EscrowParams

data Action
  = Redeem | Refund

data RedeemFailReason = DeadlinePassed
    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

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)

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)

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

escrowAddress :: Ledger.CardanoAddress
escrowAddress :: CardanoAddress
escrowAddress = NetworkId -> TypedValidator Escrow -> CardanoAddress
forall a. NetworkId -> TypedValidator a -> CardanoAddress
Scripts.validatorCardanoAddress NetworkId
Params.testnet TypedValidator Escrow
escrowInstance

escrowInstance :: V2.TypedValidator Escrow
escrowInstance :: TypedValidator Escrow
escrowInstance = CompiledCode (ValidatorType Escrow)
-> CompiledCode (ValidatorType Escrow -> UntypedValidator)
-> TypedValidator Escrow
forall a.
CompiledCode (ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> TypedValidator a
V2.mkTypedValidator @Escrow
    $$(PlutusTx.compile [|| validate ||])
    $$(PlutusTx.compile [|| wrap ||])
      where
        wrap :: (EscrowParams -> Action -> ScriptContext -> Bool)
-> UntypedValidator
wrap = (UnsafeFromData EscrowParams, UnsafeFromData Action) =>
(EscrowParams -> Action -> ScriptContext -> Bool)
-> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator @ScriptContextV2 @EscrowParams @Action

{-# INLINABLE validate #-}
validate :: EscrowParams -> Action -> V2.ScriptContext -> Bool
validate :: EscrowParams -> Action -> ScriptContext -> Bool
validate EscrowParams
params Action
action V2.ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
V2.scriptContextTxInfo=TxInfo
txInfo} =
  case Action
action of
    Action
Redeem ->
          -- Can't redeem after the deadline
      let notLapsed :: Bool
notLapsed = EscrowParams -> POSIXTime
deadline EscrowParams
params POSIXTime -> Interval POSIXTime -> Bool
forall a. Ord a => a -> Interval a -> Bool
`after` TxInfo -> Interval POSIXTime
txInfoValidRange TxInfo
txInfo
          -- Payee has to have been paid
          paid :: Bool
paid      = TxInfo -> PubKeyHash -> Value
valuePaidTo TxInfo
txInfo (PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash (PaymentPubKeyHash -> PubKeyHash)
-> PaymentPubKeyHash -> PubKeyHash
forall a b. (a -> b) -> a -> b
$ EscrowParams -> PaymentPubKeyHash
payee EscrowParams
params) Value -> Value -> Bool
`geq` EscrowParams -> Value
expecting EscrowParams
params
       in BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"escrow-deadline-lapsed" Bool
notLapsed
          Bool -> Bool -> Bool
&& BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"escrow-not-paid" Bool
paid
    Action
Refund ->
          -- Has to be the person that locked value requesting the refund
      let signed :: Bool
signed = TxInfo
txInfo TxInfo -> PubKeyHash -> Bool
`txSignedBy` PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash (EscrowParams -> PaymentPubKeyHash
payee EscrowParams
params)
          -- And we only refund after the deadline has passed
          lapsed :: Bool
lapsed = (EscrowParams -> POSIXTime
deadline EscrowParams
params 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
txInfo
       in BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"escrow-not-signed" Bool
signed
          -- && traceIfFalse "refund-too-early" lapsed
          Bool -> Bool -> Bool
&& BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"refund-too-early" Bool
lapsed

-- | Lock the 'paying' 'Value' in the output of this script, with the
-- requirement that the transaction validates before the 'deadline'.
lockEp :: Promise () EscrowSchema EscrowError ()
lockEp :: Promise () EscrowSchema EscrowError ()
lockEp = forall a w (s :: Row *) e b.
(HasEndpoint "lock" 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 @"lock" ((EscrowParams
  -> Contract
       ()
       ('R
          '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
             "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
             "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
       EscrowError
       ())
 -> Promise
      ()
      ('R
         '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
            "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
            "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
      EscrowError
      ())
-> (EscrowParams
    -> Contract
         ()
         ('R
            '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
               "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
               "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
         EscrowError
         ())
-> Promise
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     ()
forall a b. (a -> b) -> a -> b
$ \EscrowParams
params -> do
  let valRange :: ValidityInterval POSIXTime
valRange = POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
Interval.lessThan (POSIXTime -> POSIXTime
forall a. Enum a => a -> a
Haskell.pred (POSIXTime -> POSIXTime) -> POSIXTime -> 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 -> POSIXTime
deadline EscrowParams
params)
      tx :: TxConstraints Action EscrowParams
tx = EscrowParams -> Value -> TxConstraints Action EscrowParams
forall o i. o -> Value -> TxConstraints i o
Constraints.mustPayToTheScriptWithDatumInTx EscrowParams
params (EscrowParams -> Value
paying EscrowParams
params)
            TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime -> TxConstraints Action EscrowParams
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange ValidityInterval POSIXTime
valRange
  Contract
  ()
  ('R
     '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
        "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
        "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
  EscrowError
  CardanoTx
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   ()
   ('R
      '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
         "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
         "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
   EscrowError
   CardanoTx
 -> Contract
      ()
      ('R
         '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
            "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
            "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
      EscrowError
      ())
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     CardanoTx
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     ()
forall a b. (a -> b) -> a -> b
$ ScriptLookups Escrow
-> TxConstraints (RedeemerType Escrow) (DatumType Escrow)
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     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
escrowInstance) TxConstraints (RedeemerType Escrow) (DatumType Escrow)
TxConstraints Action EscrowParams
tx
         Contract
  ()
  ('R
     '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
        "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
        "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
  EscrowError
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
               "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
               "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
         EscrowError
         UnbalancedTx)
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract
  ()
  ('R
     '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
        "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
        "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
  EscrowError
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
               "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
               "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
         EscrowError
         CardanoTx)
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     CardanoTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx

-- | Attempts to redeem the 'Value' locked into this script by paying in from
-- the callers address to the payee.
redeemEp :: Promise () EscrowSchema EscrowError RedeemSuccess
redeemEp :: Promise () EscrowSchema EscrowError RedeemSuccess
redeemEp = (EscrowParams
 -> Contract
      ()
      ('R
         '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
            "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
            "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
      EscrowError
      RedeemSuccess)
-> Promise
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     RedeemSuccess
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" EscrowParams
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     RedeemSuccess
forall e w (s :: Row *).
(AsContractError e, AsEscrowError e) =>
EscrowParams -> Contract w s e RedeemSuccess
redeem
  where
    redeem :: EscrowParams -> Contract w s e RedeemSuccess
redeem EscrowParams
params = do
      POSIXTime
time <- (POSIXTime, POSIXTime) -> POSIXTime
forall a b. (a, b) -> b
snd ((POSIXTime, POSIXTime) -> POSIXTime)
-> Contract w s e (POSIXTime, POSIXTime)
-> Contract w s e POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract w s e (POSIXTime, POSIXTime)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (POSIXTime, POSIXTime)
currentNodeClientTimeRange
      PaymentPubKeyHash
pk <- Contract w s e PaymentPubKeyHash
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e PaymentPubKeyHash
ownFirstPaymentPubKeyHash
      Map TxOutRef DecoratedTxOut
unspentOutputs <- CardanoAddress -> Contract w s e (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress -> Contract w s e (Map TxOutRef DecoratedTxOut)
utxosAt CardanoAddress
escrowAddress

      let value :: Value
value = (DecoratedTxOut -> Value) -> Map TxOutRef DecoratedTxOut -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DecoratedTxOut -> Value
Ledger.decoratedTxOutPlutusValue Map TxOutRef DecoratedTxOut
unspentOutputs
          validityTimeRange :: ValidityInterval POSIXTime
validityTimeRange = POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
Interval.lessThan (POSIXTime -> POSIXTime
forall a. Enum a => a -> a
Haskell.pred (POSIXTime -> POSIXTime) -> POSIXTime -> 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 -> POSIXTime
deadline EscrowParams
params)
          tx :: TxConstraints Action EscrowParams
tx = Map TxOutRef DecoratedTxOut
-> Action -> TxConstraints Action EscrowParams
forall i o. Map TxOutRef DecoratedTxOut -> i -> TxConstraints i o
Constraints.spendUtxosFromTheScript Map TxOutRef DecoratedTxOut
unspentOutputs Action
Redeem
                      TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime -> TxConstraints Action EscrowParams
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange ValidityInterval POSIXTime
validityTimeRange
                      -- Pay me the output of this script
                      TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
forall a. Semigroup a => a -> a -> a
<> PaymentPubKeyHash -> Value -> TxConstraints Action EscrowParams
forall i o. PaymentPubKeyHash -> Value -> TxConstraints i o
Constraints.mustPayToPubKey PaymentPubKeyHash
pk Value
value
                      -- Pay the payee their due
                      TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
forall a. Semigroup a => a -> a -> a
<> PaymentPubKeyHash -> Value -> TxConstraints Action EscrowParams
forall i o. PaymentPubKeyHash -> Value -> TxConstraints i o
Constraints.mustPayToPubKey (EscrowParams -> PaymentPubKeyHash
payee EscrowParams
params) (EscrowParams -> Value
expecting EscrowParams
params)

      if POSIXTime
time POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
>= EscrowParams -> POSIXTime
deadline EscrowParams
params
      then AReview e RedeemFailReason
-> RedeemFailReason -> Contract w s e RedeemSuccess
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview e RedeemFailReason
forall r. AsEscrowError r => Prism' r RedeemFailReason
_RedeemFailed RedeemFailReason
DeadlinePassed
      else do
        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
escrowInstance
                              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 EscrowParams
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
        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 e CardanoTx -> Contract w s e RedeemSuccess
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

-- | Refunds the locked amount back to the 'payee'.
refundEp :: Promise () EscrowSchema EscrowError RefundSuccess
refundEp :: Promise () EscrowSchema EscrowError RefundSuccess
refundEp = (EscrowParams
 -> Contract
      ()
      ('R
         '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
            "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
            "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
      EscrowError
      RefundSuccess)
-> Promise
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     RefundSuccess
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" EscrowParams
-> Contract
     ()
     ('R
        '[ "lock" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "redeem" ':-> (EndpointValue EscrowParams, ActiveEndpoint),
           "refund" ':-> (EndpointValue EscrowParams, ActiveEndpoint)])
     EscrowError
     RefundSuccess
forall e w (s :: Row *).
(AsContractError e, AsEscrowError e) =>
EscrowParams -> Contract w s e RefundSuccess
refund
  where
    refund :: EscrowParams -> Contract w s e RefundSuccess
refund EscrowParams
params = do
      Map TxOutRef DecoratedTxOut
unspentOutputs <- CardanoAddress -> Contract w s e (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress -> Contract w s e (Map TxOutRef DecoratedTxOut)
utxosAt CardanoAddress
escrowAddress

      let tx :: TxConstraints Action EscrowParams
tx = Map TxOutRef DecoratedTxOut
-> Action -> TxConstraints Action EscrowParams
forall i o. Map TxOutRef DecoratedTxOut -> i -> TxConstraints i o
Constraints.spendUtxosFromTheScript Map TxOutRef DecoratedTxOut
unspentOutputs Action
Refund
                  TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime -> TxConstraints Action EscrowParams
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange (POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
Interval.from (EscrowParams -> POSIXTime
deadline EscrowParams
params))
                  TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
-> TxConstraints Action EscrowParams
forall a. Semigroup a => a -> a -> a
<> PaymentPubKeyHash -> TxConstraints Action EscrowParams
forall i o. PaymentPubKeyHash -> TxConstraints i o
Constraints.mustBeSignedBy (EscrowParams -> PaymentPubKeyHash
payee EscrowParams
params)

      if TxConstraints Action EscrowParams -> Bool
forall i o. TxConstraints i o -> Bool
Constraints.modifiesUtxoSet TxConstraints Action EscrowParams
tx
      then do
        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
escrowInstance
                              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 EscrowParams
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
        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 e CardanoTx -> Contract w s e RefundSuccess
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
      else AReview e () -> () -> Contract w s e RefundSuccess
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview e ()
forall r. AsEscrowError r => Prism' r ()
_RefundFailed ()

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