Merge pull request #77 from j-mueller/use-cases

[CGP-70] Add crowdfunding use case

default.nix

@@ -58,6 +58,7 @@ let
       plutus-exe = addRealTimeTestLogs (filterSource super.plutus-exe);
       core-to-plc = doHaddockHydra (addRealTimeTestLogs (filterSource super.core-to-plc));
       plutus-th = doHaddockHydra (addRealTimeTestLogs (filterSource super.plutus-th));
+      plutus-use-cases = addRealTimeTestLogs (filterSource super.plutus-use-cases);
     };
   };
   other = rec {

plutus-use-cases/LICENSE

@@ -0,0 +1,11 @@
+Copyright Input Output (c) 2018
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

plutus-use-cases/README.md

@@ -0,0 +1,2 @@
+# plutus-use-cases
+

plutus-use-cases/plutus-use-cases.cabal

@@ -0,0 +1,45 @@
+cabal-version: 2.0
+name: plutus-use-cases
+version: 0.1.0.0
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+copyright: Copyright: (c) 2018 Input Output
+maintainer: [email protected]
+stability: experimental
+author: Manuel M T Chakravarty, Jann Müller
+synopsis: 
+  Collection of smart contracts to develop the plutus/wallet interface
+description: 
+  Collection of smart contracts to develop the plutus/wallet interface.
+category: Language
+extra-doc-files: README.md
+
+source-repository head
+  type: git
+  location: https://github.com/input-output-hk/plutus-prototype
+
+library
+  hs-source-dirs: src
+  build-depends:
+    base -any,
+    mtl -any,
+    template-haskell -any,
+    transformers -any,
+    plutus-th -any,
+    language-plutus-core -any,
+    core-to-plc -any
+  default-language: Haskell2010
+  default-extensions: ExplicitForAll ScopedTypeVariables
+                      DeriveGeneric StandaloneDeriving DeriveLift
+                      GeneralizedNewtypeDeriving DeriveFunctor DeriveFoldable
+                      DeriveTraversable
+  exposed-modules:
+    Language.Plutus.Coordination.Plutus
+    Language.Plutus.Coordination.Contracts
+    Language.Plutus.Coordination.Contracts.CrowdFunding
+    Language.Plutus.Coordination.Contracts.Swap
+  ghc-options:
+    -Wall -Wnoncanonical-monad-instances
+    -Wincomplete-uni-patterns -Wincomplete-record-updates
+    -Wredundant-constraints -Widentities

plutus-use-cases/src/Language/Plutus/Coordination/Contracts.hs

@@ -0,0 +1,33 @@
+module Language.Plutus.Coordination.Contracts(
+  -- * Example contracts
+  module CrowdFunding,
+  module Swap
+  ) where
+
+import           Language.Plutus.Coordination.Contracts.CrowdFunding as CrowdFunding
+import           Language.Plutus.Coordination.Contracts.Swap         as Swap
+
+{- Note [Contracts and Validator Scripts]
+
+Central to both examples are the validator scripts in
+`CrowdFunding.contributionScript` and `Swap.swapValidator`. In both cases we
+construct a PLC script using the core-to-plutus plugin (with Template Haskell
+and the `plc` marker respectively).
+
+The validator scripts currently have a type
+
+Redeemer -> DataScript -> PendingTx -> a -> ()
+
+Where `a` is a parameter specific to the contract (supplied by the user before
+the contract begins). The actual signature of a validator script looks like
+
+Redeemer -> DataScript -> PendingTx -> ()
+
+So, in the future, the Plutus coordinating code has to translate the `a` value
+to PLC and apply it to the function. This could be done with a type class
+(similar to aeson's ToJSON).
+
+In order to validate transactions, cardano nodes have to do the same with
+`PendingTx` which holds information about the transaction.
+
+-}

plutus-use-cases/src/Language/Plutus/Coordination/Contracts/CrowdFunding.hs

@@ -0,0 +1,165 @@
+-- | 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 NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# OPTIONS -fplugin=Language.Plutus.CoreToPLC.Plugin -fplugin-opt Language.Plutus.CoreToPLC.Plugin:dont-typecheck #-}
+module Language.Plutus.Coordination.Contracts.CrowdFunding (
+    Campaign(..)
+    -- * Functionality for campaign contributors
+    , contribute
+    , contributionScript
+    , refund
+    , refundTrigger
+    -- * Functionality for campaign owners
+    , collect
+    , collectFundsTrigger
+    ) where
+
+import           Language.Plutus.Coordination.Plutus
+import           Language.Plutus.TH (plutusT)
+import qualified Language.Plutus.CoreToPLC.Primitives as Prim
+
+import           Prelude                              (Bool (..), Either (..), Num (..), Ord (..), succ, sum, ($))
+
+-- | A crowdfunding campaign.
+data Campaign = Campaign
+    { campaignDeadline           :: !BlockHeight
+    , campaignTarget             :: !Value
+    , campaignCollectionDeadline :: !BlockHeight
+    , campaignOwner              :: !PubKey
+    }
+
+-- | Contribute funds to the campaign (contributor)
+--
+contribute :: Campaign -> Value -> TxM [TxOutRef]
+contribute c value = do
+    assert (value > 0)
+    contributorPubKey <- lookupMyPubKey
+    myPayment         <- createPayment (value + standardTxFee)
+    let validator = contributionScript c contributorPubKey
+        o = TxOutScript
+            value
+            (hash validator)
+            0 -- TODO: contributorPubKey ought to be lifted into PLC at coordination runtime as the data script
+    submitTransaction Tx
+      { txInputs  = Left myPayment -- TODO: Change to [myPayment] when we can have a list of inputs
+      , txOutputs = Left o
+      }
+    -- the transaction above really ought to be merely a transaction *template* and the transaction fee ought to be
+    -- added by the Wallet API Plutus library on the basis of the size and other costs of the transaction
+
+-- | The validator script that determines whether the campaign owner can
+--   retrieve the funds or the contributors can claim a refund.
+--
+--   Assume there is a campaign `c :: Campaign` with two contributors
+--   (identified by public key pc_1 and pc_2) and one campaign owner (pco).
+--   Each contributor creates a transaction, t_1 and t_2, whose outputs are
+--   locked by the scripts `contributionScript c pc_1` and `contributionScript
+--   c pc_1` respectively.
+--   There are two outcomes for the campaign.
+--   1. Campaign owner collects the funds from both contributors. In this case
+--      the owner creates a single transaction with two inputs, referring to
+--      t_1 and t_2. Each input contains the script `contributionScript c`
+--      specialised to a contributor. This case is covered by the
+--      definition for `payToOwner` below.
+--   2. Refund. In this case each contributor creates a transaction with a
+--      single input claiming back their part of the funds. This case is
+--      covered by the `refundable` branch.
+contributionScript ::
+       Campaign
+    -> PubKey
+    -> PlutusTx
+contributionScript _ _  = PlutusTx inner where
+
+    --   See note [Contracts and Validator Scripts] in
+    --       Language.Plutus.Coordination.Contracts
+    inner = $$(plutusT [|| (\() () p Campaign{..} contribPubKey ->
+        let
+            -- | Check that a transaction input is signed by the private key of the given
+            --   public key.
+            signedBy :: TxIn -> PubKey -> Bool
+            signedBy = Prim.error
+
+            infixr 3 &&
+            (&&) :: Bool -> Bool -> Bool
+            (&&) = Prim.error
+
+            -- | Check that a pending transaction is signed by the private key
+            --   of the given public key.
+            signedByT :: PendingTx -> PubKey -> Bool
+            signedByT = Prim.error
+
+            PendingTx pendingTxBlockHeight _ pendingTxTransaction = p
+
+            isValid = case pendingTxTransaction of
+                Tx (Right (t1, t2)) _ -> -- the "successful campaign" branch
+                    let
+                        TxIn (TxOutRef v1 _ _) _ _ _ = t1
+                        TxIn (TxOutRef v2 _ _) _ _ _ = t2
+                        pledgedFunds = v1 + v2
+
+                        payToOwner = pendingTxBlockHeight > campaignDeadline &&
+                                     pendingTxBlockHeight <= campaignCollectionDeadline &&
+                                     pledgedFunds >= campaignTarget &&
+                                     signedByT p campaignOwner
+                    in payToOwner
+                Tx (Left t) _ -> -- the "refund" branch
+                    let
+                        -- Check that a refund transaction only spends the
+                        -- amount that was pledged by the contributor
+                        -- identified by `contribPubKey`
+                        contributorOnly = signedBy t contribPubKey
+                        refundable   = pendingTxBlockHeight > campaignCollectionDeadline &&
+                                       contributorOnly &&
+                                       signedByT p contribPubKey
+                        -- In case of a refund, we can only collect the funds that
+                        -- were committed by this contributor
+                    in refundable
+        in
+        if isValid then () else Prim.error) ||])
+
+-- | Given the campaign data and the output from the contributing transaction,
+--   make a trigger that fires when the transaction can be refunded.
+refundTrigger :: Campaign -> Address -> EventTrigger
+refundTrigger Campaign{..} t = And
+    (FundsAtAddress [t]  (GEQ 1))
+    (BlockHeightRange (GEQ $ succ campaignCollectionDeadline))
+
+-- | Given the public key of the campaign owner, generate an event trigger that
+-- fires when the funds can be collected.
+collectFundsTrigger :: Campaign -> [Address] -> EventTrigger
+collectFundsTrigger Campaign{..} ts = And
+    (FundsAtAddress ts $ GEQ campaignTarget)
+    (BlockHeightRange $ Interval campaignDeadline campaignCollectionDeadline)
+
+refund :: Campaign -> TxOutRef -> TxM [TxOutRef]
+refund c ref = do
+    kp <- lookupMyKeyPair
+    let scr = contributionScript c (pubKey kp)
+        o = TxOutPubKey value (pubKey kp)
+        i = txInSign ref scr unitPLC unitPLC kp
+    submitTransaction $ Tx {
+      txInputs = Left i,
+      txOutputs = Left o
+    } where
+      value = txOutRefValue ref - standardTxFee -- TODO: Fee should be inserted by wallet
+
+-- | Collect all campaign funds (campaign owner)
+--
+--
+collect :: Campaign -> (TxOutRef, PubKey) -> (TxOutRef, PubKey) -> TxM [TxOutRef]
+collect cmp (o1, ck1) (o2, ck2) = do
+    ownerKeyPair <- lookupMyKeyPair
+    let oo  = TxOutPubKey value (pubKey ownerKeyPair)
+        scr = contributionScript cmp
+    submitTransaction Tx
+      { txInputs  = Right (
+          txInSign o1 (scr ck1) unitPLC unitPLC ownerKeyPair,
+          txInSign o2 (scr ck2) unitPLC unitPLC ownerKeyPair)
+      , txOutputs = Left oo
+      }
+    where
+      value = sum [txOutRefValue outRef | outRef <- [o1, o2]] + standardTxFee