Plutus Playground Smart Contract

Playground.hs

import qualified Data.Text                 as T
import           Language.Plutus.Contract  hiding (when)
-- ScriptLookups semigroup is defined based on the standard prelude <> and doesn't like the plutus one
import           Language.PlutusTx.Prelude hiding  ((<>)) 
import qualified Language.PlutusTx                 as PlutusTx
import           Playground.Contract
import           Control.Monad                     (void, when)
import           Ledger                            (Address (..), Slot (Slot), Validator, pubKeyHash, txOutTxDatum, txOutValue, txOutTxOut, TxOut, ValidatorCtx, Value, scriptAddress, PubKeyHash, Datum(..), TxOutTx, PubKeyHash (..), ValidatorCtx (..), validatorHash, txInInfoValue )
import qualified Ledger.Typed.Scripts              as Scripts
import qualified Data.Map                          as Map
import           Data.List                         (groupBy, maximumBy) 
import qualified Ledger.Ada                        as Ada
import           Data.Maybe                        (fromJust, catMaybes)
import           Ledger.Constraints                (TxConstraints, mustBeSignedBy, mustPayToTheScript, mustValidateIn, mustPayToPubKey, mustPayToOtherScript, scriptInstanceLookups,SomeLookupsAndConstraints (..), mkSomeTx, unspentOutputs, ScriptLookups(..))
import qualified Ledger.Contexts                   as Validation
import           Control.Lens

import           Data.Semigroup                   


quorum = 2

-- | Helper functions
lovelaceValue :: Value -> Integer
lovelaceValue value = Ada.getLovelace $ Ada.fromValue value

datumToData :: (PlutusTx.IsData a) => Datum -> Maybe a
datumToData datum = PlutusTx.fromData (getDatum datum)

{-# INLINABLE extractData #-}
extractData :: (PlutusTx.IsData a) => TxOutTx -> Maybe a
extractData txOut = do
                        datum <- txOutTxDatum txOut
                        datumToData datum   


-- Vote script
data VoteDatum = VoteDatum {   
      amount          :: Integer 
     ,owner           :: PubKeyHash
    } deriving (Generic, Show)

PlutusTx.makeLift ''VoteDatum
PlutusTx.makeIsData ''VoteDatum

extractVote :: TxOutTx -> Maybe VoteDatum
extractVote = extractData

data Vote
instance Scripts.ScriptType Vote where
    type instance RedeemerType Vote = ()
    type instance DatumType Vote = VoteDatum

{-# INLINABLE voteScript #-}
voteScript  ::  ValidatorHash -> VoteDatum -> () -> ValidatorCtx -> Bool 
voteScript treasury _ _ ctx@ValidatorCtx{valCtxTxInfo=txInfo} = 
                    -- check there should be an input to the treasury
                    -- check vote value goes back to owner
                    True


voteScriptInstance :: ValidatorHash -> Scripts.ScriptInstance Vote
voteScriptInstance treasuryHash = Scripts.validator @Vote
    ($$(PlutusTx.compile [|| voteScript ||]) `PlutusTx.applyCode` PlutusTx.liftCode treasuryHash)
    $$(PlutusTx.compile [|| wrap ||]) where
        wrap = Scripts.wrapValidator @VoteDatum @()

voteScriptAddress :: ValidatorHash -> Address
voteScriptAddress treasuryHash = Ledger.scriptAddress (Scripts.validatorScript ( voteScriptInstance treasuryHash))

-- Treasury script
data Treasury
instance Scripts.ScriptType Treasury where
    type instance RedeemerType Treasury = ()
    type instance DatumType Treasury = ()

{-# INLINABLE treasuryScript #-}
treasuryScript  ::  () -> () -> ValidatorCtx -> Bool 
treasuryScript _ _ ctx =
                    -- check vote count
                    -- check result of vote is 'effected'
                    -- valuePaidTo
                    -- at least 1 lovelace in treasury
                    -- count the votes, make sure they all the same
                    -- legnth votes > quorum

                    -- I have enough votes (filter from utxo inputs) to the same choice
                    True

treasuryScriptInstance :: Scripts.ScriptInstance Treasury
treasuryScriptInstance  = Scripts.validator @Treasury
    $$(PlutusTx.compile [|| treasuryScript ||])
    $$(PlutusTx.compile [|| wrap ||]) where
        wrap = Scripts.wrapValidator @() @()


treasuryScriptHash :: ValidatorHash
treasuryScriptHash = validatorHash $ Scripts.validatorScript treasuryScriptInstance

treasuryScriptAddress :: Address
treasuryScriptAddress = Ledger.scriptAddress (Scripts.validatorScript treasuryScriptInstance)

type VotingSchema =
    BlockchainActions
        .\/ Endpoint "1-setup treasury" Integer
        .\/ Endpoint "2-vote" Integer
        .\/ Endpoint "3-collect" ()

initiateVoting :: Contract VotingSchema T.Text ()
initiateVoting = do
                    trasuryAmount <- endpoint @"1-setup treasury" @Integer
                    let            
                        tx = mustPayToTheScript () ( Ada.lovelaceValueOf trasuryAmount) 
                    void (submitTxConstraints treasuryScriptInstance tx)

vote :: Contract VotingSchema T.Text ()
vote= do
        amountVoted <- endpoint @"2-vote" @Integer
        voter <- pubKeyHash <$> ownPubKey
        let
          txAddVote = mustPayToTheScript VoteDatum{amount=amountVoted, owner=voter} ( Ada.lovelaceValueOf 1)
        void (submitTxConstraints (voteScriptInstance treasuryScriptHash) txAddVote)

tally :: Contract VotingSchema T.Text ()
tally = do        
            endpoint @"3-collect" @()
            votesUtxo <- utxoAt (voteScriptAddress treasuryScriptHash)
            treasuryUtxo <- utxoAt treasuryScriptAddress              
            collector <- pubKeyHash <$> ownPubKey
            let
                utxoList = Map.toList votesUtxo
                comparator (_,x) (_,y) = amount (fromJust (extractVote x) ) == amount (fromJust (extractVote y))
                tally = map (\vs -> (vs, length vs)) $ groupBy comparator utxoList
                compareTally (_, count1) (_, count2) = count1 `compare` count2
                (winner, count) = maximumBy compareTally tally
                winningUtxos = Map.fromList winner
            if count >= quorum then 
                -- spend from the treasury the amount voted for
                -- send back the lovelaces to the vote script (or something)
                let 
                    ScriptAddress treasuryScriptHash = treasuryScriptAddress
                    winningAmount = amount (fromJust (extractVote (snd $ head winner) ) )  
                    datum = Datum $ PlutusTx.toData $ VoteDatum{amount=winningAmount}
                                
                    -- pay the voted amount from the treasury            
                    txPayCollector = mustPayToPubKey collector ( Ada.lovelaceValueOf winningAmount)
                    txRepayTreasury = mustPayToTheScript datum ( Ada.lovelaceValueOf (totalTreasury - winningAmount) )


                    --votes are repaid
                    makeRepayment utxo =  let 
                                            voter = owner $ fromJust (extractVote utxo) 
                                          in 
                                            mustPayToPubKey voter (Ada.lovelaceValueOf 1) 
                    repayVoteTxs = map (makeRepayment.snd) utxoList
                    txRepayVotes = foldl1 (<>) repayVoteTxs

                    txWinningUtxos = collectFromScript winningUtxos ()
                    txInputTreasury = collectFromScript treasuryUtxo ()            

                    treasuryUtxosConstraint = txInputTreasury <> txPayCollector <> txBackToTreasury
                    treasuryLookups = (scriptInstanceLookups treasuryScriptInstance) <> (unspentOutputs treasuryUtxo)

-- 
                    votesUtxosConstraint = txWinningUtxos <> txRepayVotes
                    votesLookups = (scriptInstanceLookups (voteScriptInstance treasuryScriptHash) ) <> (unspentOutputs winningUtxos)

                    treasurySpend = SomeLookupsAndConstraints treasuryLookups treasuryUtxosConstraint
                    voteSpend = SomeLookupsAndConstraints votesLookups votesUtxosConstraint
                in                     
                  do
                    logInfo @String $ show winningAmount 
                    void $ do
                        tx <- either (throwError . review _ConstraintResolutionError) pure (mkSomeTx [treasurySpend, voteSpend])
                        submitUnbalancedTx tx
            else
                throwError $ T.pack "Not enough votes"

endpoints :: Contract VotingSchema T.Text ()
endpoints = initiateVoting `select` vote `select` tally

mkSchemaDefinitions ''VotingSchema

$(mkKnownCurrencies [])

Simulation.json

[0,[{"simulationWallets":[{"simulatorWalletWallet":{"getWallet":1},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":2},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":3},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":4},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":5},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":6},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}}],"simulationName":"Simulation 1","simulationId":1,"simulationActions":[{"caller":{"getWallet":1},"argumentValues":{"endpointDescription":{"getEndpointDescription":"1-setup treasury"},"argument":{"s":1,"e":0,"c":[5],"tag":"FormIntegerF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"},{"caller":{"getWallet":2},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-vote"},"argument":{"s":1,"e":0,"c":[1],"tag":"FormIntegerF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"},{"caller":{"getWallet":3},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-vote"},"argument":{"s":1,"e":0,"c":[1],"tag":"FormIntegerF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"},{"caller":{"getWallet":4},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-vote"},"argument":{"s":1,"e":0,"c":[1],"tag":"FormIntegerF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"},{"caller":{"getWallet":5},"argumentValues":{"endpointDescription":{"getEndpointDescription":"2-vote"},"argument":{"s":1,"e":0,"c":[3],"tag":"FormIntegerF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"},{"caller":{"getWallet":6},"argumentValues":{"endpointDescription":{"getEndpointDescription":"3-collect"},"argument":{"tag":"FormUnitF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"}]}]]