-- | Crowdfunding contract implemented using the [[Plutus]] interface.
-- This is the fully parallel version that collects all contributions
-- in a single transaction. This is, of course, limited by the maximum
-- number of inputs a transaction can have.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE ViewPatterns        #-}
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
{-# OPTIONS_GHC -fno-specialise #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:debug-context #-}

module Plutus.Contracts.Crowdfunding (
    -- * Campaign parameters
      Campaign(..)
    , CrowdfundingSchema
    , crowdfunding
    , theCampaign
    -- * Functionality for campaign contributors
    , contribute
    , Contribution(..)
    -- * Functionality for campaign owners
    , scheduleCollection
    , campaignAddress
    -- * Validator script
    , contributionScript
    , mkValidator
    , mkCampaign
    , CampaignAction(..)
    , collectionRange
    , refundRange
    -- * Traces
    , startCampaign
    , makeContribution
    , successfulCampaign
    ) where

import Cardano.Node.Emulator.Internal.Node.Params qualified as Params
import Cardano.Node.Emulator.Internal.Node.TimeSlot qualified as TimeSlot
import Control.Applicative (Applicative (..))
import Control.Monad (void)
import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text)
import Data.Text qualified as Text
import GHC.Generics (Generic)
import Ledger (PaymentPubKeyHash (unPaymentPubKeyHash), getCardanoTxId)
import Ledger qualified
import Ledger.Interval qualified as Interval
import Ledger.Tx.CardanoAPI (fromCardanoTxId)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Tx.Constraints.ValidityInterval qualified as ValidityInterval
import Ledger.Typed.Scripts qualified as Scripts hiding (validatorHash)
import Plutus.Contract
import Plutus.Script.Utils.Ada qualified as Ada
import Plutus.Script.Utils.V2.Scripts as V2
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2 hiding (validatorHash)
import Plutus.Trace.Effects.EmulatorControl (getSlotConfig)
import Plutus.Trace.Emulator (ContractHandle, EmulatorTrace)
import Plutus.Trace.Emulator qualified as Trace
import Plutus.V2.Ledger.Api qualified as V2
import Plutus.V2.Ledger.Contexts qualified as V2
import PlutusTx qualified
import PlutusTx.Prelude hiding (Applicative (..), Semigroup (..), return, (<$>), (>>), (>>=))
import Prelude (Semigroup (..), (<$>), (>>=))
import Prelude qualified as Haskell
import Wallet.Emulator (Wallet (..), knownWallet)
import Wallet.Emulator qualified as Emulator

-- | A crowdfunding campaign.
data Campaign = Campaign
    { Campaign -> POSIXTime
campaignDeadline           :: V2.POSIXTime
    -- ^ The date by which the campaign funds can be contributed.
    , Campaign -> POSIXTime
campaignCollectionDeadline :: V2.POSIXTime
    -- ^ The date by which the campaign owner has to collect the funds
    , Campaign -> PaymentPubKeyHash
campaignOwner              :: PaymentPubKeyHash
    -- ^ Public key of the campaign owner. This key is entitled to retrieve the
    --   funds if the campaign is successful.
    } deriving ((forall x. Campaign -> Rep Campaign x)
-> (forall x. Rep Campaign x -> Campaign) -> Generic Campaign
forall x. Rep Campaign x -> Campaign
forall x. Campaign -> Rep Campaign x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Campaign x -> Campaign
$cfrom :: forall x. Campaign -> Rep Campaign x
Generic, [Campaign] -> Encoding
[Campaign] -> Value
Campaign -> Encoding
Campaign -> Value
(Campaign -> Value)
-> (Campaign -> Encoding)
-> ([Campaign] -> Value)
-> ([Campaign] -> Encoding)
-> ToJSON Campaign
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Campaign] -> Encoding
$ctoEncodingList :: [Campaign] -> Encoding
toJSONList :: [Campaign] -> Value
$ctoJSONList :: [Campaign] -> Value
toEncoding :: Campaign -> Encoding
$ctoEncoding :: Campaign -> Encoding
toJSON :: Campaign -> Value
$ctoJSON :: Campaign -> Value
ToJSON, Value -> Parser [Campaign]
Value -> Parser Campaign
(Value -> Parser Campaign)
-> (Value -> Parser [Campaign]) -> FromJSON Campaign
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Campaign]
$cparseJSONList :: Value -> Parser [Campaign]
parseJSON :: Value -> Parser Campaign
$cparseJSON :: Value -> Parser Campaign
FromJSON, Int -> Campaign -> ShowS
[Campaign] -> ShowS
Campaign -> String
(Int -> Campaign -> ShowS)
-> (Campaign -> String) -> ([Campaign] -> ShowS) -> Show Campaign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Campaign] -> ShowS
$cshowList :: [Campaign] -> ShowS
show :: Campaign -> String
$cshow :: Campaign -> String
showsPrec :: Int -> Campaign -> ShowS
$cshowsPrec :: Int -> Campaign -> ShowS
Haskell.Show)

PlutusTx.makeLift ''Campaign

-- | Action that can be taken by the participants in this contract. A value of
--   `CampaignAction` is provided as the redeemer. The validator script then
--   checks if the conditions for performing this action are met.
--
data CampaignAction = Collect | Refund

PlutusTx.unstableMakeIsData ''CampaignAction
PlutusTx.makeLift ''CampaignAction

type CrowdfundingSchema =
    Endpoint "schedule collection" ()
    .\/ Endpoint "contribute" Contribution

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

-- | Construct a 'Campaign' value from the campaign parameters,
--   using the wallet's public key.
mkCampaign :: V2.POSIXTime -> V2.POSIXTime -> Wallet -> Campaign
mkCampaign :: POSIXTime -> POSIXTime -> Wallet -> Campaign
mkCampaign POSIXTime
ddl POSIXTime
collectionDdl Wallet
ownerWallet =
    Campaign :: POSIXTime -> POSIXTime -> PaymentPubKeyHash -> Campaign
Campaign
        { campaignDeadline :: POSIXTime
campaignDeadline = POSIXTime
ddl
        , campaignCollectionDeadline :: POSIXTime
campaignCollectionDeadline = POSIXTime
collectionDdl
        , campaignOwner :: PaymentPubKeyHash
campaignOwner = Wallet -> PaymentPubKeyHash
Emulator.mockWalletPaymentPubKeyHash Wallet
ownerWallet
        }

-- | The 'ValidityInterval POSIXTime' during which the funds can be collected
{-# INLINABLE collectionRange #-}
collectionRange :: Campaign -> ValidityInterval.ValidityInterval V2.POSIXTime
collectionRange :: Campaign -> ValidityInterval POSIXTime
collectionRange Campaign
cmp = POSIXTime -> POSIXTime -> ValidityInterval POSIXTime
forall a. a -> a -> ValidityInterval a
ValidityInterval.interval (Campaign -> POSIXTime
campaignDeadline Campaign
cmp) (Campaign -> POSIXTime
campaignCollectionDeadline Campaign
cmp)

-- | The 'ValidityInterval POSIXTime' during which a refund may be claimed
{-# INLINABLE refundRange #-}
refundRange :: Campaign -> ValidityInterval.ValidityInterval V2.POSIXTime
refundRange :: Campaign -> ValidityInterval POSIXTime
refundRange Campaign
cmp = POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
ValidityInterval.from (Campaign -> POSIXTime
campaignCollectionDeadline Campaign
cmp)

data Crowdfunding
instance Scripts.ValidatorTypes Crowdfunding where
    type instance RedeemerType Crowdfunding = CampaignAction
    type instance DatumType Crowdfunding = PaymentPubKeyHash

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

{-# INLINABLE validRefund #-}
validRefund :: Campaign -> PaymentPubKeyHash -> V2.TxInfo -> Bool
validRefund :: Campaign -> PaymentPubKeyHash -> TxInfo -> Bool
validRefund Campaign
campaign PaymentPubKeyHash
contributor TxInfo
txinfo =
    -- Check that the transaction falls in the refund range of the campaign
    ValidityInterval POSIXTime -> Interval POSIXTime
forall a. ValidityInterval a -> Interval a
ValidityInterval.toPlutusInterval (Campaign -> ValidityInterval POSIXTime
refundRange Campaign
campaign) Interval POSIXTime -> Interval POSIXTime -> Bool
forall a. Ord a => Interval a -> Interval a -> Bool
`Interval.contains` TxInfo -> Interval POSIXTime
V2.txInfoValidRange TxInfo
txinfo
    -- Check that the transaction is signed by the contributor
    Bool -> Bool -> Bool
&& (TxInfo
txinfo TxInfo -> PubKeyHash -> Bool
`V2.txSignedBy` PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
contributor)

{-# INLINABLE validCollection #-}
validCollection :: Campaign -> V2.TxInfo -> Bool
validCollection :: Campaign -> TxInfo -> Bool
validCollection Campaign
campaign TxInfo
txinfo =
    -- Check that the transaction falls in the collection range of the campaign
    (ValidityInterval POSIXTime -> Interval POSIXTime
forall a. ValidityInterval a -> Interval a
ValidityInterval.toPlutusInterval (Campaign -> ValidityInterval POSIXTime
collectionRange Campaign
campaign) Interval POSIXTime -> Interval POSIXTime -> Bool
forall a. Ord a => Interval a -> Interval a -> Bool
`Interval.contains` TxInfo -> Interval POSIXTime
V2.txInfoValidRange TxInfo
txinfo)
    -- Check that the transaction is signed by the campaign owner
    Bool -> Bool -> Bool
&& (TxInfo
txinfo TxInfo -> PubKeyHash -> Bool
`V2.txSignedBy` PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash (Campaign -> PaymentPubKeyHash
campaignOwner Campaign
campaign))

{-# INLINABLE mkValidator #-}
-- | The validator script is of type 'CrowdfundingValidator', and is
-- additionally parameterized by a 'Campaign' definition. This argument is
-- provided by the Plutus client, using 'PlutusTx.applyCode'.
-- As a result, the 'Campaign' definition is part of the script address,
-- and different campaigns have different addresses. The Campaign{..} syntax
-- means that all fields of the 'Campaign' value are in scope
-- (for example 'campaignDeadline' in l. 70).
mkValidator :: Campaign -> PaymentPubKeyHash -> CampaignAction -> V2.ScriptContext -> Bool
mkValidator :: Campaign
-> PaymentPubKeyHash -> CampaignAction -> ScriptContext -> Bool
mkValidator Campaign
c PaymentPubKeyHash
con CampaignAction
act V2.ScriptContext{TxInfo
scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo :: TxInfo
V2.scriptContextTxInfo} = case CampaignAction
act of
    -- the "refund" branch
    CampaignAction
Refund  -> Campaign -> PaymentPubKeyHash -> TxInfo -> Bool
validRefund Campaign
c PaymentPubKeyHash
con TxInfo
scriptContextTxInfo
    -- the "collection" branch
    CampaignAction
Collect -> Campaign -> TxInfo -> Bool
validCollection Campaign
c TxInfo
scriptContextTxInfo

-- | The validator script that determines whether the campaign owner can
--   retrieve the funds or the contributors can claim a refund.
--
contributionScript :: Campaign -> V2.Validator
contributionScript :: Campaign -> Validator
contributionScript = TypedValidator Crowdfunding -> Validator
forall a. TypedValidator a -> Validator
V2.validatorScript (TypedValidator Crowdfunding -> Validator)
-> (Campaign -> TypedValidator Crowdfunding)
-> Campaign
-> Validator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Campaign -> TypedValidator Crowdfunding
typedValidator

-- | The address of a [[Campaign]]
campaignAddress :: Campaign -> V2.ValidatorHash
campaignAddress :: Campaign -> ValidatorHash
campaignAddress = Validator -> ValidatorHash
V2.validatorHash (Validator -> ValidatorHash)
-> (Campaign -> Validator) -> Campaign -> ValidatorHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Campaign -> Validator
contributionScript

-- | The crowdfunding contract for the 'Campaign'.
crowdfunding :: Campaign -> Contract () CrowdfundingSchema ContractError ()
crowdfunding :: Campaign -> Contract () CrowdfundingSchema ContractError ()
crowdfunding Campaign
c = [Promise
   ()
   ('R
      '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
         "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
   ContractError
   ()]
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall w (s :: Row *) e a. [Promise w s e a] -> Contract w s e a
selectList [Campaign -> Promise () CrowdfundingSchema ContractError ()
contribute Campaign
c, Campaign -> Promise () CrowdfundingSchema ContractError ()
scheduleCollection Campaign
c]

-- | A sample campaign
theCampaign :: V2.POSIXTime -> Campaign
theCampaign :: POSIXTime -> Campaign
theCampaign POSIXTime
startTime = Campaign :: POSIXTime -> POSIXTime -> PaymentPubKeyHash -> Campaign
Campaign
    { campaignDeadline :: POSIXTime
campaignDeadline = POSIXTime
startTime POSIXTime -> POSIXTime -> POSIXTime
forall a. AdditiveSemigroup a => a -> a -> a
+ POSIXTime
20000
    , campaignCollectionDeadline :: POSIXTime
campaignCollectionDeadline = POSIXTime
startTime POSIXTime -> POSIXTime -> POSIXTime
forall a. AdditiveSemigroup a => a -> a -> a
+ POSIXTime
30000
    , campaignOwner :: PaymentPubKeyHash
campaignOwner = Wallet -> PaymentPubKeyHash
Emulator.mockWalletPaymentPubKeyHash (Integer -> Wallet
knownWallet Integer
1)
    }

-- | The "contribute" branch of the contract for a specific 'Campaign'. Exposes
--   an endpoint that allows the user to enter their public key and the
--   contribution. Then waits until the campaign is over, and collects the
--   refund if the funding was not collected.
contribute :: Campaign -> Promise () CrowdfundingSchema ContractError ()
contribute :: Campaign -> Promise () CrowdfundingSchema ContractError ()
contribute Campaign
cmp = forall a w (s :: Row *) e b.
(HasEndpoint "contribute" 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 @"contribute" ((Contribution
  -> Contract
       ()
       ('R
          '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
             "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
       ContractError
       ())
 -> Promise
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      ())
-> (Contribution
    -> Contract
         ()
         ('R
            '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
               "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
         ContractError
         ())
-> Promise
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a b. (a -> b) -> a -> b
$ \Contribution{Value
contribValue :: Value
contribValue :: Contribution -> Value
contribValue} -> do
    forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
forall w (s :: Row *) e. ToJSON Text => Text -> Contract w s e ()
logInfo @Text (Text
 -> Contract
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      ())
-> Text
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a b. (a -> b) -> a -> b
$ Text
"Contributing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Value -> String
forall a. Show a => a -> String
Haskell.show Value
contribValue)
    PaymentPubKeyHash
contributor <- Contract
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
  PaymentPubKeyHash
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e PaymentPubKeyHash
ownFirstPaymentPubKeyHash
    let inst :: TypedValidator Crowdfunding
inst = Campaign -> TypedValidator Crowdfunding
typedValidator Campaign
cmp
        validityTimeRange :: ValidityInterval POSIXTime
validityTimeRange = POSIXTime -> ValidityInterval POSIXTime
forall a. a -> ValidityInterval a
ValidityInterval.lessThan (Campaign -> POSIXTime
campaignDeadline Campaign
cmp)
        tx :: TxConstraints CampaignAction PaymentPubKeyHash
tx = PaymentPubKeyHash
-> Value -> TxConstraints CampaignAction PaymentPubKeyHash
forall o i. o -> Value -> TxConstraints i o
Constraints.mustPayToTheScriptWithDatumInTx PaymentPubKeyHash
contributor Value
contribValue
                TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime
-> TxConstraints CampaignAction PaymentPubKeyHash
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange ValidityInterval POSIXTime
validityTimeRange
    TxId
txid <- (CardanoTx -> TxId)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     TxId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CardanoTx -> TxId
getCardanoTxId (Contract
   ()
   ('R
      '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
         "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
   ContractError
   CardanoTx
 -> Contract
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      TxId)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     TxId
forall a b. (a -> b) -> a -> b
$ ScriptLookups Crowdfunding
-> TxConstraints
     (RedeemerType Crowdfunding) (DatumType Crowdfunding)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     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 Crowdfunding -> ScriptLookups Crowdfunding
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator Crowdfunding
inst) TxConstraints (RedeemerType Crowdfunding) (DatumType Crowdfunding)
TxConstraints CampaignAction PaymentPubKeyHash
tx
        Contract
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
               "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
         ContractError
         UnbalancedTx)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
               "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
         ContractError
         CardanoTx)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx

    Map TxOutRef DecoratedTxOut
utxo <- CardanoAddress
-> POSIXTime
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress
-> POSIXTime -> Contract w s e (Map TxOutRef DecoratedTxOut)
watchAddressUntilTime (NetworkId -> TypedValidator Crowdfunding -> CardanoAddress
forall a. NetworkId -> TypedValidator a -> CardanoAddress
Scripts.validatorCardanoAddress NetworkId
Params.testnet TypedValidator Crowdfunding
inst) (POSIXTime
 -> Contract
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      (Map TxOutRef DecoratedTxOut))
-> POSIXTime
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     (Map TxOutRef DecoratedTxOut)
forall a b. (a -> b) -> a -> b
$ Campaign -> POSIXTime
campaignCollectionDeadline Campaign
cmp

    -- 'utxo' is the set of unspent outputs at the campaign address at the
    -- collection deadline. If 'utxo' still contains our own contribution
    -- then we can claim a refund.

    let flt :: TxOutRef -> DecoratedTxOut -> Bool
flt Ledger.TxOutRef{TxId
txOutRefId :: TxOutRef -> TxId
txOutRefId :: TxId
txOutRefId} DecoratedTxOut
_ = TxId -> TxId
fromCardanoTxId TxId
txid TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
Haskell.== TxId
txOutRefId
        tx' :: TxConstraints CampaignAction PaymentPubKeyHash
tx' = (TxOutRef -> DecoratedTxOut -> Bool)
-> Map TxOutRef DecoratedTxOut
-> CampaignAction
-> TxConstraints CampaignAction PaymentPubKeyHash
forall i o.
(TxOutRef -> DecoratedTxOut -> Bool)
-> Map TxOutRef DecoratedTxOut -> i -> TxConstraints i o
Constraints.spendUtxosFromTheScriptFilter TxOutRef -> DecoratedTxOut -> Bool
flt Map TxOutRef DecoratedTxOut
utxo CampaignAction
Refund
                TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime
-> TxConstraints CampaignAction PaymentPubKeyHash
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange (Campaign -> ValidityInterval POSIXTime
refundRange Campaign
cmp)
                TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> PaymentPubKeyHash -> TxConstraints CampaignAction PaymentPubKeyHash
forall i o. PaymentPubKeyHash -> TxConstraints i o
Constraints.mustBeSignedBy PaymentPubKeyHash
contributor
    if TxConstraints CampaignAction PaymentPubKeyHash -> Bool
forall i o. TxConstraints i o -> Bool
Constraints.modifiesUtxoSet TxConstraints CampaignAction PaymentPubKeyHash
tx'
    then do
        Text
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo @Text Text
"Claiming refund"
        Contract
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
  CardanoTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   ()
   ('R
      '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
         "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
   ContractError
   CardanoTx
 -> Contract
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      ())
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a b. (a -> b) -> a -> b
$ ScriptLookups Crowdfunding
-> TxConstraints
     (RedeemerType Crowdfunding) (DatumType Crowdfunding)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     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 Crowdfunding -> ScriptLookups Crowdfunding
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator Crowdfunding
inst
                             ScriptLookups Crowdfunding
-> ScriptLookups Crowdfunding -> ScriptLookups Crowdfunding
forall a. Semigroup a => a -> a -> a
<> Map TxOutRef DecoratedTxOut -> ScriptLookups Crowdfunding
forall a. Map TxOutRef DecoratedTxOut -> ScriptLookups a
Constraints.unspentOutputs Map TxOutRef DecoratedTxOut
utxo) TxConstraints (RedeemerType Crowdfunding) (DatumType Crowdfunding)
TxConstraints CampaignAction PaymentPubKeyHash
tx'
            Contract
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
               "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
         ContractError
         UnbalancedTx)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
               "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
         ContractError
         CardanoTx)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx
    else ()
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | The campaign owner's branch of the contract for a given 'Campaign'. It
--   watches the campaign address for contributions and collects them if
--   the funding goal was reached in time.
scheduleCollection :: Campaign -> Promise () CrowdfundingSchema ContractError ()
scheduleCollection :: Campaign -> Promise () CrowdfundingSchema ContractError ()
scheduleCollection Campaign
cmp = forall a w (s :: Row *) e b.
(HasEndpoint "schedule collection" 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 @"schedule collection" ((()
  -> Contract
       ()
       ('R
          '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
             "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
       ContractError
       ())
 -> Promise
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      ())
-> (()
    -> Contract
         ()
         ('R
            '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
               "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
         ContractError
         ())
-> Promise
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a b. (a -> b) -> a -> b
$ \() -> do
    let inst :: TypedValidator Crowdfunding
inst = Campaign -> TypedValidator Crowdfunding
typedValidator Campaign
cmp

    -- Expose an endpoint that lets the user fire the starting gun on the
    -- campaign. (This endpoint isn't technically necessary, we could just
    -- run the 'trg' action right away)
    Text
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo @Text Text
"Campaign started. Waiting for campaign deadline to collect funds."

    POSIXTime
_ <- POSIXTime
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     POSIXTime
forall w (s :: Row *) e.
AsContractError e =>
POSIXTime -> Contract w s e POSIXTime
awaitTime (POSIXTime
 -> Contract
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      POSIXTime)
-> POSIXTime
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     POSIXTime
forall a b. (a -> b) -> a -> b
$ Campaign -> POSIXTime
campaignDeadline Campaign
cmp
    Map TxOutRef DecoratedTxOut
unspentOutputs <- CardanoAddress
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress -> Contract w s e (Map TxOutRef DecoratedTxOut)
utxosAt (NetworkId -> TypedValidator Crowdfunding -> CardanoAddress
forall a. NetworkId -> TypedValidator a -> CardanoAddress
Scripts.validatorCardanoAddress NetworkId
Params.testnet TypedValidator Crowdfunding
inst)

    let tx :: TxConstraints CampaignAction PaymentPubKeyHash
tx = Map TxOutRef DecoratedTxOut
-> CampaignAction -> TxConstraints CampaignAction PaymentPubKeyHash
forall i o. Map TxOutRef DecoratedTxOut -> i -> TxConstraints i o
Constraints.spendUtxosFromTheScript Map TxOutRef DecoratedTxOut
unspentOutputs CampaignAction
Collect
            TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> PaymentPubKeyHash -> TxConstraints CampaignAction PaymentPubKeyHash
forall i o. PaymentPubKeyHash -> TxConstraints i o
Constraints.mustBeSignedBy (Campaign -> PaymentPubKeyHash
campaignOwner Campaign
cmp)
            TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
-> TxConstraints CampaignAction PaymentPubKeyHash
forall a. Semigroup a => a -> a -> a
<> ValidityInterval POSIXTime
-> TxConstraints CampaignAction PaymentPubKeyHash
forall i o. ValidityInterval POSIXTime -> TxConstraints i o
Constraints.mustValidateInTimeRange (Campaign -> ValidityInterval POSIXTime
collectionRange Campaign
cmp)

    Text
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
logInfo @Text Text
"Collecting funds"
    Contract
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
  CardanoTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract
   ()
   ('R
      '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
         "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
   ContractError
   CardanoTx
 -> Contract
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      ())
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a b. (a -> b) -> a -> b
$ ScriptLookups Crowdfunding
-> TxConstraints
     (RedeemerType Crowdfunding) (DatumType Crowdfunding)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     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 Crowdfunding -> ScriptLookups Crowdfunding
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator Crowdfunding
inst
                         ScriptLookups Crowdfunding
-> ScriptLookups Crowdfunding -> ScriptLookups Crowdfunding
forall a. Semigroup a => a -> a -> a
<> Map TxOutRef DecoratedTxOut -> ScriptLookups Crowdfunding
forall a. Map TxOutRef DecoratedTxOut -> ScriptLookups a
Constraints.unspentOutputs Map TxOutRef DecoratedTxOut
unspentOutputs) TxConstraints (RedeemerType Crowdfunding) (DatumType Crowdfunding)
TxConstraints CampaignAction PaymentPubKeyHash
tx
        Contract
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
               "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
         ContractError
         UnbalancedTx)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
  UnbalancedTx
-> (UnbalancedTx
    -> Contract
         ()
         ('R
            '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
               "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
         ContractError
         CardanoTx)
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx

-- | Call the "schedule collection" endpoint and instruct the campaign owner's
--   wallet (wallet 1) to start watching the campaign address.
startCampaign :: EmulatorTrace (ContractHandle () CrowdfundingSchema ContractError)
startCampaign :: EmulatorTrace (ContractHandle () CrowdfundingSchema ContractError)
startCampaign = do
    POSIXTime
startTime <- SlotConfig -> POSIXTime
TimeSlot.scSlotZeroTime (SlotConfig -> POSIXTime)
-> Eff EmulatorEffects SlotConfig -> Eff EmulatorEffects POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff EmulatorEffects SlotConfig
forall (effs :: [* -> *]).
Member EmulatorControl effs =>
Eff effs SlotConfig
getSlotConfig
    ContractHandle
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
hdl <- Wallet
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
-> Eff
     EmulatorEffects
     (ContractHandle
        ()
        ('R
           '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
              "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
        ContractError)
forall (contract :: * -> Row * -> * -> * -> *) w (s :: Row *) e
       (effs :: [* -> *]).
(IsContract contract, ContractConstraints s, Show e, ToJSON e,
 FromJSON e, ToJSON w, FromJSON w, Member StartContract effs,
 Monoid w) =>
Wallet -> contract w s e () -> Eff effs (ContractHandle w s e)
Trace.activateContractWallet (Integer -> Wallet
knownWallet Integer
1) (Campaign -> Contract () CrowdfundingSchema ContractError ()
Campaign
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
crowdfunding (Campaign
 -> Contract
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      ())
-> Campaign
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Campaign
theCampaign POSIXTime
startTime)
    ContractHandle
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
-> () -> Eff EmulatorEffects ()
forall (l :: Symbol) ep w (s :: Row *) e (effs :: [* -> *]).
(ToJSON ep, ContractConstraints s, HasEndpoint l ep s,
 Member RunContract effs) =>
ContractHandle w s e -> ep -> Eff effs ()
Trace.callEndpoint @"schedule collection" ContractHandle
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
hdl ()
    ContractHandle
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
-> Eff
     EmulatorEffects
     (ContractHandle
        ()
        ('R
           '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
              "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
        ContractError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContractHandle
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
hdl

-- | Call the "contribute" endpoint, contributing the amount from the wallet
makeContribution :: Wallet -> V2.Value -> EmulatorTrace ()
makeContribution :: Wallet -> Value -> Eff EmulatorEffects ()
makeContribution Wallet
w Value
v = do
    POSIXTime
startTime <- SlotConfig -> POSIXTime
TimeSlot.scSlotZeroTime (SlotConfig -> POSIXTime)
-> Eff EmulatorEffects SlotConfig -> Eff EmulatorEffects POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff EmulatorEffects SlotConfig
forall (effs :: [* -> *]).
Member EmulatorControl effs =>
Eff effs SlotConfig
getSlotConfig
    ContractHandle
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
hdl <- Wallet
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
-> Eff
     EmulatorEffects
     (ContractHandle
        ()
        ('R
           '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
              "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
        ContractError)
forall (contract :: * -> Row * -> * -> * -> *) w (s :: Row *) e
       (effs :: [* -> *]).
(IsContract contract, ContractConstraints s, Show e, ToJSON e,
 FromJSON e, ToJSON w, FromJSON w, Member StartContract effs,
 Monoid w) =>
Wallet -> contract w s e () -> Eff effs (ContractHandle w s e)
Trace.activateContractWallet Wallet
w (Campaign -> Contract () CrowdfundingSchema ContractError ()
Campaign
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
crowdfunding (Campaign
 -> Contract
      ()
      ('R
         '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
            "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
      ContractError
      ())
-> Campaign
-> Contract
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError
     ()
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Campaign
theCampaign POSIXTime
startTime)
    ContractHandle
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
-> Contribution -> Eff EmulatorEffects ()
forall (l :: Symbol) ep w (s :: Row *) e (effs :: [* -> *]).
(ToJSON ep, ContractConstraints s, HasEndpoint l ep s,
 Member RunContract effs) =>
ContractHandle w s e -> ep -> Eff effs ()
Trace.callEndpoint @"contribute" ContractHandle
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
hdl Contribution :: Value -> Contribution
Contribution{contribValue :: Value
contribValue=Value
v}

-- | Run a successful campaign with contributions from wallets 2, 3 and 4.
successfulCampaign :: EmulatorTrace ()
successfulCampaign :: Eff EmulatorEffects ()
successfulCampaign = do
    ContractHandle
  ()
  ('R
     '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
        "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
  ContractError
_ <- EmulatorTrace (ContractHandle () CrowdfundingSchema ContractError)
Eff
  EmulatorEffects
  (ContractHandle
     ()
     ('R
        '[ "contribute" ':-> (EndpointValue Contribution, ActiveEndpoint),
           "schedule collection" ':-> (EndpointValue (), ActiveEndpoint)])
     ContractError)
startCampaign
    Wallet -> Value -> Eff EmulatorEffects ()
makeContribution (Integer -> Wallet
knownWallet Integer
2) (Micro -> Value
Ada.adaValueOf Micro
10)
    Wallet -> Value -> Eff EmulatorEffects ()
makeContribution (Integer -> Wallet
knownWallet Integer
3) (Micro -> Value
Ada.adaValueOf Micro
10)
    Wallet -> Value -> Eff EmulatorEffects ()
makeContribution (Integer -> Wallet
knownWallet Integer
4) (Micro -> Value
Ada.adaValueOf Micro
2.5)
    Eff EmulatorEffects Slot -> Eff EmulatorEffects ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff EmulatorEffects Slot -> Eff EmulatorEffects ())
-> Eff EmulatorEffects Slot -> Eff EmulatorEffects ()
forall a b. (a -> b) -> a -> b
$ Slot -> Eff EmulatorEffects Slot
forall (effs :: [* -> *]).
Member Waiting effs =>
Slot -> Eff effs Slot
Trace.waitUntilSlot Slot
21