{-# LANGUAGE ConstraintKinds    #-}
{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE TypeFamilies       #-}
{-# LANGUAGE TypeOperators      #-}
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
{-# OPTIONS_GHC -fno-specialise #-}
module Plutus.Contracts.Vesting (
    -- $vesting
    VestingParams(..),
    VestingSchema,
    VestingTranche(..),
    VestingError(..),
    AsVestingError(..),
    totalAmount,
    vestingContract,
    validate,
    vestingScript
    ) where

import Control.Lens
import Control.Monad (void, when)
import Data.Aeson (FromJSON, ToJSON)
import Data.Map qualified as Map
import Prelude (Semigroup (..))

import Cardano.Node.Emulator.Internal.Node (pNetworkId, testnet)
import GHC.Generics (Generic)
import Ledger (CardanoAddress, POSIXTime, POSIXTimeRange, PaymentPubKeyHash (unPaymentPubKeyHash),
               decoratedTxOutPlutusValue)
import Ledger.Interval qualified as Interval
import Ledger.Tx.Constraints (TxConstraints, mustBeSignedBy, mustPayToTheScriptWithDatumInTx, mustValidateInTimeRange)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Tx.Constraints.ValidityInterval qualified as ValidityInterval
import Ledger.Typed.Scripts (ValidatorTypes (..))
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.Contract
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.Script.Utils.Value (Value)
import Plutus.Script.Utils.Value qualified as Value
import Plutus.V2.Ledger.Api (ScriptContext (..), TxInfo (..), Validator)
import Plutus.V2.Ledger.Contexts qualified as V2
import PlutusTx qualified
import PlutusTx.Prelude hiding (Semigroup (..), fold)
import Prelude qualified as Haskell

{- |
    A simple vesting scheme. Money is locked by a contract and may only be
    retrieved after some time has passed.

    This is our first example of a contract that covers multiple transactions,
    with a contract state that changes over time.

    In our vesting scheme the money will be released in two _tranches_ (parts):
    A smaller part will be available after an initial number of time has
    passed, and the entire amount will be released at the end. The owner of the
    vesting scheme does not have to take out all the money at once: They can
    take out any amount up to the total that has been released so far. The
    remaining funds stay locked and can be retrieved later.

    Let's start with the data types.

-}

type VestingSchema =
        Endpoint "vest funds" ()
        .\/ Endpoint "retrieve funds" Value

data Vesting

instance ValidatorTypes Vesting where
    type instance RedeemerType Vesting = ()
    type instance DatumType Vesting = ()

-- | Tranche of a vesting scheme.
data VestingTranche = VestingTranche {
    VestingTranche -> POSIXTime
vestingTrancheDate   :: POSIXTime,
    VestingTranche -> Value
vestingTrancheAmount :: Value
    } deriving (forall x. VestingTranche -> Rep VestingTranche x)
-> (forall x. Rep VestingTranche x -> VestingTranche)
-> Generic VestingTranche
forall x. Rep VestingTranche x -> VestingTranche
forall x. VestingTranche -> Rep VestingTranche x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VestingTranche x -> VestingTranche
$cfrom :: forall x. VestingTranche -> Rep VestingTranche x
Generic

PlutusTx.makeLift ''VestingTranche

-- | A vesting scheme consisting of two tranches. Each tranche defines a date
--   (POSIX time) after which an additional amount can be spent.
data VestingParams = VestingParams {
    VestingParams -> VestingTranche
vestingTranche1 :: VestingTranche,
    VestingParams -> VestingTranche
vestingTranche2 :: VestingTranche,
    VestingParams -> PaymentPubKeyHash
vestingOwner    :: PaymentPubKeyHash
    } deriving (forall x. VestingParams -> Rep VestingParams x)
-> (forall x. Rep VestingParams x -> VestingParams)
-> Generic VestingParams
forall x. Rep VestingParams x -> VestingParams
forall x. VestingParams -> Rep VestingParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VestingParams x -> VestingParams
$cfrom :: forall x. VestingParams -> Rep VestingParams x
Generic

PlutusTx.makeLift ''VestingParams

{-# INLINABLE totalAmount #-}
-- | The total amount vested
totalAmount :: VestingParams -> Value
totalAmount :: VestingParams -> Value
totalAmount VestingParams{VestingTranche
vestingTranche1 :: VestingTranche
vestingTranche1 :: VestingParams -> VestingTranche
vestingTranche1,VestingTranche
vestingTranche2 :: VestingTranche
vestingTranche2 :: VestingParams -> VestingTranche
vestingTranche2} =
    VestingTranche -> Value
vestingTrancheAmount VestingTranche
vestingTranche1 Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ VestingTranche -> Value
vestingTrancheAmount VestingTranche
vestingTranche2

{-# INLINABLE availableFrom #-}
-- | The amount guaranteed to be available from a given tranche in a given time range.
availableFrom :: VestingTranche -> POSIXTimeRange -> Value
availableFrom :: VestingTranche -> POSIXTimeRange -> Value
availableFrom (VestingTranche POSIXTime
d Value
v) POSIXTimeRange
range =
    -- The valid range is an open-ended range starting from the tranche vesting date
    let validRange :: POSIXTimeRange
validRange = POSIXTime -> POSIXTimeRange
forall a. a -> Interval a
Interval.from POSIXTime
d
    -- If the valid range completely contains the argument range (meaning in particular
    -- that the start time of the argument range is after the tranche vesting date), then
    -- the money in the tranche is available, otherwise nothing is available.
    in if POSIXTimeRange
validRange POSIXTimeRange -> POSIXTimeRange -> Bool
forall a. Ord a => Interval a -> Interval a -> Bool
`Interval.contains` POSIXTimeRange
range then Value
v else Value
forall a. AdditiveMonoid a => a
zero

availableAt :: VestingParams -> POSIXTime -> Value
availableAt :: VestingParams -> POSIXTime -> Value
availableAt VestingParams{VestingTranche
vestingTranche1 :: VestingTranche
vestingTranche1 :: VestingParams -> VestingTranche
vestingTranche1, VestingTranche
vestingTranche2 :: VestingTranche
vestingTranche2 :: VestingParams -> VestingTranche
vestingTranche2} POSIXTime
time =
    let f :: VestingTranche -> Value
f VestingTranche{POSIXTime
vestingTrancheDate :: POSIXTime
vestingTrancheDate :: VestingTranche -> POSIXTime
vestingTrancheDate, Value
vestingTrancheAmount :: Value
vestingTrancheAmount :: VestingTranche -> Value
vestingTrancheAmount} =
            if POSIXTime
time POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
>= POSIXTime
vestingTrancheDate then Value
vestingTrancheAmount else Value
forall a. Monoid a => a
mempty
    in (VestingTranche -> Value) -> [VestingTranche] -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap VestingTranche -> Value
f [VestingTranche
vestingTranche1, VestingTranche
vestingTranche2]

{-# INLINABLE remainingFrom #-}
-- | The amount that has not been released from this tranche yet
remainingFrom :: VestingTranche -> POSIXTimeRange -> Value
remainingFrom :: VestingTranche -> POSIXTimeRange -> Value
remainingFrom t :: VestingTranche
t@VestingTranche{Value
vestingTrancheAmount :: Value
vestingTrancheAmount :: VestingTranche -> Value
vestingTrancheAmount} POSIXTimeRange
range =
    Value
vestingTrancheAmount Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
- VestingTranche -> POSIXTimeRange -> Value
availableFrom VestingTranche
t POSIXTimeRange
range

{-# INLINABLE validate #-}
validate :: VestingParams -> () -> () -> V2.ScriptContext -> Bool
validate :: VestingParams -> () -> () -> ScriptContext -> Bool
validate VestingParams{VestingTranche
vestingTranche1 :: VestingTranche
vestingTranche1 :: VestingParams -> VestingTranche
vestingTranche1, VestingTranche
vestingTranche2 :: VestingTranche
vestingTranche2 :: VestingParams -> VestingTranche
vestingTranche2, PaymentPubKeyHash
vestingOwner :: PaymentPubKeyHash
vestingOwner :: VestingParams -> PaymentPubKeyHash
vestingOwner} () () ctx :: ScriptContext
ctx@V2.ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo=txInfo :: TxInfo
txInfo@TxInfo{POSIXTimeRange
txInfoValidRange :: TxInfo -> POSIXTimeRange
txInfoValidRange :: POSIXTimeRange
txInfoValidRange}} =
    let
        remainingActual :: Value
remainingActual  = TxInfo -> ValidatorHash -> Value
V2.valueLockedBy TxInfo
txInfo (ScriptContext -> ValidatorHash
V2.ownHash ScriptContext
ctx)

        remainingExpected :: Value
remainingExpected =
            VestingTranche -> POSIXTimeRange -> Value
remainingFrom VestingTranche
vestingTranche1 POSIXTimeRange
txInfoValidRange
            Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ VestingTranche -> POSIXTimeRange -> Value
remainingFrom VestingTranche
vestingTranche2 POSIXTimeRange
txInfoValidRange

    in Value
remainingActual Value -> Value -> Bool
`Value.geq` Value
remainingExpected
            -- The policy encoded in this contract
            -- is "vestingOwner can do with the funds what they want" (as opposed
            -- to "the funds must be paid to vestingOwner"). This is enforcey by
            -- the following condition:
            Bool -> Bool -> Bool
&& TxInfo -> PubKeyHash -> Bool
V2.txSignedBy TxInfo
txInfo (PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
vestingOwner)
            -- That way the recipient of the funds can pay them to whatever address they
            -- please, potentially saving one transaction.

vestingScript :: VestingParams -> Validator
vestingScript :: VestingParams -> Validator
vestingScript = TypedValidator Vesting -> Validator
forall a. TypedValidator a -> Validator
Scripts.validatorScript (TypedValidator Vesting -> Validator)
-> (VestingParams -> TypedValidator Vesting)
-> VestingParams
-> Validator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VestingParams -> TypedValidator Vesting
typedValidator

typedValidator :: VestingParams -> V2.TypedValidator Vesting
typedValidator :: VestingParams -> TypedValidator Vesting
typedValidator = CompiledCode (VestingParams -> ValidatorType Vesting)
-> CompiledCode (ValidatorType Vesting -> UntypedValidator)
-> VestingParams
-> TypedValidator Vesting
forall a param.
Lift DefaultUni param =>
CompiledCode (param -> ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> param
-> TypedValidator a
V2.mkTypedValidatorParam @Vesting
    $$(PlutusTx.compile [|| validate ||])
    $$(PlutusTx.compile [|| wrap ||])
    where
        wrap :: (() -> () -> ScriptContext -> Bool) -> UntypedValidator
wrap = (() -> () -> ScriptContext -> Bool) -> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator

contractAddress :: VestingParams -> CardanoAddress
contractAddress :: VestingParams -> CardanoAddress
contractAddress = NetworkId -> TypedValidator Vesting -> CardanoAddress
forall a. NetworkId -> TypedValidator a -> CardanoAddress
Scripts.validatorCardanoAddress NetworkId
testnet (TypedValidator Vesting -> CardanoAddress)
-> (VestingParams -> TypedValidator Vesting)
-> VestingParams
-> CardanoAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VestingParams -> TypedValidator Vesting
typedValidator

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

makeClassyPrisms ''VestingError

instance AsContractError VestingError where
    _ContractError :: p ContractError (f ContractError)
-> p VestingError (f VestingError)
_ContractError = p ContractError (f ContractError)
-> p VestingError (f VestingError)
forall r. AsVestingError r => Prism' r ContractError
_VContractError

vestingContract :: VestingParams -> Contract () VestingSchema VestingError ()
vestingContract :: VestingParams -> Contract () VestingSchema VestingError ()
vestingContract VestingParams
vesting = [Promise
   ()
   ('R
      '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
         "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
   VestingError
   ()]
-> Contract
     ()
     ('R
        '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
           "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
     VestingError
     ()
forall w (s :: Row *) e a. [Promise w s e a] -> Contract w s e a
selectList [Promise
  ()
  ('R
     '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
        "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
  VestingError
  ()
vest, Promise
  ()
  ('R
     '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
        "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
  VestingError
  ()
retrieve]
  where
    vest :: Promise
  ()
  ('R
     '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
        "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
  VestingError
  ()
vest = forall a w (s :: Row *) e b.
(HasEndpoint "vest funds" 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 @"vest funds" ((()
  -> Contract
       ()
       ('R
          '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
             "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
       VestingError
       ())
 -> Promise
      ()
      ('R
         '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
            "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
      VestingError
      ())
-> (()
    -> Contract
         ()
         ('R
            '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
               "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
         VestingError
         ())
-> Promise
     ()
     ('R
        '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
           "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
     VestingError
     ()
forall a b. (a -> b) -> a -> b
$ \() -> VestingParams
-> Contract
     ()
     ('R
        '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
           "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
     VestingError
     ()
forall e w (s :: Row *).
AsVestingError e =>
VestingParams -> Contract w s e ()
vestFundsC VestingParams
vesting
    retrieve :: Promise
  ()
  ('R
     '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
        "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
  VestingError
  ()
retrieve = forall a w (s :: Row *) e b.
(HasEndpoint "retrieve funds" 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 @"retrieve funds" ((Value
  -> Contract
       ()
       ('R
          '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
             "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
       VestingError
       ())
 -> Promise
      ()
      ('R
         '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
            "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
      VestingError
      ())
-> (Value
    -> Contract
         ()
         ('R
            '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
               "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
         VestingError
         ())
-> Promise
     ()
     ('R
        '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
           "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
     VestingError
     ()
forall a b. (a -> b) -> a -> b
$ \Value
payment -> do
        Liveness
liveness <- VestingParams
-> Value
-> Contract
     ()
     ('R
        '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
           "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
     VestingError
     Liveness
forall e w (s :: Row *).
AsVestingError e =>
VestingParams -> Value -> Contract w s e Liveness
retrieveFundsC VestingParams
vesting Value
payment
        case Liveness
liveness of
            Liveness
Alive -> Promise
  ()
  ('R
     '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
        "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
  VestingError
  ()
-> Contract
     ()
     ('R
        '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
           "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
     VestingError
     ()
forall w (s :: Row *) e a. Promise w s e a -> Contract w s e a
awaitPromise Promise
  ()
  ('R
     '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
        "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
  VestingError
  ()
retrieve
            Liveness
Dead  -> ()
-> Contract
     ()
     ('R
        '[ "retrieve funds" ':-> (EndpointValue Value, ActiveEndpoint),
           "vest funds" ':-> (EndpointValue (), ActiveEndpoint)])
     VestingError
     ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

payIntoContract :: Value -> TxConstraints () ()
payIntoContract :: Value -> TxConstraints () ()
payIntoContract = () -> Value -> TxConstraints () ()
forall o i. o -> Value -> TxConstraints i o
mustPayToTheScriptWithDatumInTx ()

vestFundsC
    :: ( AsVestingError e
       )
    => VestingParams
    -> Contract w s e ()
vestFundsC :: VestingParams -> Contract w s e ()
vestFundsC VestingParams
vesting = (VestingError -> e)
-> Contract w s VestingError () -> Contract w s e ()
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e VestingError -> VestingError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e VestingError
forall r. AsVestingError r => Prism' r VestingError
_VestingError) (Contract w s VestingError () -> Contract w s e ())
-> Contract w s VestingError () -> Contract w s e ()
forall a b. (a -> b) -> a -> b
$ do
    let tx :: TxConstraints () ()
tx = Value -> TxConstraints () ()
payIntoContract (VestingParams -> Value
totalAmount VestingParams
vesting)
    ScriptLookups Vesting
-> TxConstraints (RedeemerType Vesting) (DatumType Vesting)
-> Contract w s VestingError 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 Vesting -> ScriptLookups Vesting
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups (TypedValidator Vesting -> ScriptLookups Vesting)
-> TypedValidator Vesting -> ScriptLookups Vesting
forall a b. (a -> b) -> a -> b
$ VestingParams -> TypedValidator Vesting
typedValidator VestingParams
vesting) TxConstraints () ()
TxConstraints (RedeemerType Vesting) (DatumType Vesting)
tx
      Contract w s VestingError UnbalancedTx
-> (UnbalancedTx -> Contract w s VestingError UnbalancedTx)
-> Contract w s VestingError UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s VestingError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract w s VestingError UnbalancedTx
-> (UnbalancedTx -> Contract w s VestingError ())
-> Contract w s VestingError ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Contract w s VestingError CardanoTx -> Contract w s VestingError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s VestingError CardanoTx
 -> Contract w s VestingError ())
-> (UnbalancedTx -> Contract w s VestingError CardanoTx)
-> UnbalancedTx
-> Contract w s VestingError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnbalancedTx -> Contract w s VestingError CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx

data Liveness = Alive | Dead

retrieveFundsC
    :: ( AsVestingError e
       )
    => VestingParams
    -> Value
    -> Contract w s e Liveness
retrieveFundsC :: VestingParams -> Value -> Contract w s e Liveness
retrieveFundsC VestingParams
vesting Value
payment = (VestingError -> e)
-> Contract w s VestingError Liveness -> Contract w s e Liveness
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e VestingError -> VestingError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e VestingError
forall r. AsVestingError r => Prism' r VestingError
_VestingError) (Contract w s VestingError Liveness -> Contract w s e Liveness)
-> Contract w s VestingError Liveness -> Contract w s e Liveness
forall a b. (a -> b) -> a -> b
$ do
    NetworkId
networkId <- Params -> NetworkId
pNetworkId (Params -> NetworkId)
-> Contract w s VestingError Params
-> Contract w s VestingError NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract w s VestingError Params
forall w (s :: Row *) e. AsContractError e => Contract w s e Params
getParams
    let inst :: TypedValidator Vesting
inst = VestingParams -> TypedValidator Vesting
typedValidator VestingParams
vesting
        addr :: CardanoAddress
addr = NetworkId -> TypedValidator Vesting -> CardanoAddress
forall a. NetworkId -> TypedValidator a -> CardanoAddress
Scripts.validatorCardanoAddress NetworkId
networkId TypedValidator Vesting
inst
    POSIXTime
now <- (POSIXTime, POSIXTime) -> POSIXTime
forall a b. (a, b) -> a
fst ((POSIXTime, POSIXTime) -> POSIXTime)
-> Contract w s VestingError (POSIXTime, POSIXTime)
-> Contract w s VestingError POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract w s VestingError (POSIXTime, POSIXTime)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (POSIXTime, POSIXTime)
currentNodeClientTimeRange
    Map TxOutRef DecoratedTxOut
unspentOutputs <- CardanoAddress
-> Contract w s VestingError (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress -> Contract w s e (Map TxOutRef DecoratedTxOut)
utxosAt CardanoAddress
addr
    let
        currentlyLocked :: Value
currentlyLocked = (DecoratedTxOut -> Value) -> [DecoratedTxOut] -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DecoratedTxOut -> Value
decoratedTxOutPlutusValue (Map TxOutRef DecoratedTxOut -> [DecoratedTxOut]
forall k a. Map k a -> [a]
Map.elems Map TxOutRef DecoratedTxOut
unspentOutputs)
        remainingValue :: Value
remainingValue = Value
currentlyLocked Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
- Value
payment
        mustRemainLocked :: Value
mustRemainLocked = VestingParams -> Value
totalAmount VestingParams
vesting Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
- VestingParams -> POSIXTime -> Value
availableAt VestingParams
vesting POSIXTime
now
        maxPayment :: Value
maxPayment = Value
currentlyLocked Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
- Value
mustRemainLocked

    Bool
-> Contract w s VestingError () -> Contract w s VestingError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value
remainingValue Value -> Value -> Bool
`Value.lt` Value
mustRemainLocked)
        (Contract w s VestingError () -> Contract w s VestingError ())
-> Contract w s VestingError () -> Contract w s VestingError ()
forall a b. (a -> b) -> a -> b
$ VestingError -> Contract w s VestingError ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (VestingError -> Contract w s VestingError ())
-> VestingError -> Contract w s VestingError ()
forall a b. (a -> b) -> a -> b
$ Value -> Value -> Value -> VestingError
InsufficientFundsError Value
payment Value
maxPayment Value
mustRemainLocked

    let liveness :: Liveness
liveness = if Value
remainingValue Value -> Value -> Bool
`Value.gt` Value
forall a. Monoid a => a
mempty then Liveness
Alive else Liveness
Dead
        remainingOutputs :: TxConstraints () ()
remainingOutputs = case Liveness
liveness of
                            Liveness
Alive -> Value -> TxConstraints () ()
payIntoContract Value
remainingValue
                            Liveness
Dead  -> TxConstraints () ()
forall a. Monoid a => a
mempty
        tx :: TxConstraints () ()
tx = Map TxOutRef DecoratedTxOut -> () -> TxConstraints () ()
forall i o. Map TxOutRef DecoratedTxOut -> i -> TxConstraints i o
Constraints.spendUtxosFromTheScript Map TxOutRef DecoratedTxOut
unspentOutputs ()
                TxConstraints () () -> TxConstraints () () -> TxConstraints () ()
forall a. Semigroup a => a -> a -> a
<> TxConstraints () ()
remainingOutputs
                TxConstraints () () -> TxConstraints () () -> TxConstraints () ()
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime -> TxConstraints () ()
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
mustValidateInTimeRange (POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
ValidityInterval.from POSIXTime
now)
                TxConstraints () () -> TxConstraints () () -> TxConstraints () ()
forall a. Semigroup a => a -> a -> a
<> PaymentPubKeyHash -> TxConstraints () ()
forall i o. PaymentPubKeyHash -> TxConstraints i o
mustBeSignedBy (VestingParams -> PaymentPubKeyHash
vestingOwner VestingParams
vesting)
                -- we don't need to add a pubkey output for 'vestingOwner' here
                -- because this will be done by the wallet when it balances the
                -- transaction.
    ScriptLookups Vesting
-> TxConstraints (RedeemerType Vesting) (DatumType Vesting)
-> Contract w s VestingError 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 Vesting -> ScriptLookups Vesting
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator Vesting
inst
                  ScriptLookups Vesting
-> ScriptLookups Vesting -> ScriptLookups Vesting
forall a. Semigroup a => a -> a -> a
<> Map TxOutRef DecoratedTxOut -> ScriptLookups Vesting
forall a. Map TxOutRef DecoratedTxOut -> ScriptLookups a
Constraints.unspentOutputs Map TxOutRef DecoratedTxOut
unspentOutputs) TxConstraints () ()
TxConstraints (RedeemerType Vesting) (DatumType Vesting)
tx
      Contract w s VestingError UnbalancedTx
-> (UnbalancedTx -> Contract w s VestingError UnbalancedTx)
-> Contract w s VestingError UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s VestingError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract w s VestingError UnbalancedTx
-> (UnbalancedTx -> Contract w s VestingError ())
-> Contract w s VestingError ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Contract w s VestingError CardanoTx -> Contract w s VestingError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s VestingError CardanoTx
 -> Contract w s VestingError ())
-> (UnbalancedTx -> Contract w s VestingError CardanoTx)
-> UnbalancedTx
-> Contract w s VestingError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnbalancedTx -> Contract w s VestingError CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx
    Liveness -> Contract w s VestingError Liveness
forall (m :: * -> *) a. Monad m => a -> m a
return Liveness
liveness