From 314f884edacce93c338eb65b71af86a2e1adc707 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Wed, 14 Jul 2021 21:17:25 +0200 Subject: [PATCH] removed solutions --- .../plutus-pioneer-program-week03.cabal | 2 - code/week03/src/Week03/Solution1.hs | 145 ------------------ code/week03/src/Week03/Solution2.hs | 127 --------------- 3 files changed, 274 deletions(-) delete mode 100644 code/week03/src/Week03/Solution1.hs delete mode 100644 code/week03/src/Week03/Solution2.hs diff --git a/code/week03/plutus-pioneer-program-week03.cabal b/code/week03/plutus-pioneer-program-week03.cabal index 91502dd..b329349 100644 --- a/code/week03/plutus-pioneer-program-week03.cabal +++ b/code/week03/plutus-pioneer-program-week03.cabal @@ -13,8 +13,6 @@ library exposed-modules: Week03.Homework1 , Week03.Homework2 , Week03.Parameterized - , Week03.Solution1 - , Week03.Solution2 , Week03.Vesting build-depends: aeson , base ^>=4.14.1.0 diff --git a/code/week03/src/Week03/Solution1.hs b/code/week03/src/Week03/Solution1.hs deleted file mode 100644 index d9fe216..0000000 --- a/code/week03/src/Week03/Solution1.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Week03.Solution1 where - -import Control.Monad hiding (fmap) -import Data.Aeson (ToJSON, FromJSON) -import Data.Map as Map -import Data.Text (Text) -import Data.Void (Void) -import GHC.Generics (Generic) -import Plutus.Contract -import qualified PlutusTx -import PlutusTx.Prelude hiding (unless) -import Ledger hiding (singleton) -import Ledger.Constraints as Constraints -import qualified Ledger.Typed.Scripts as Scripts -import Ledger.Ada as Ada -import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema) -import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions) -import Playground.Types (KnownCurrency (..)) -import Prelude (IO, Show (..), String) -import qualified Prelude as P -import Text.Printf (printf) - -data VestingDatum = VestingDatum - { beneficiary1 :: PubKeyHash - , beneficiary2 :: PubKeyHash - , deadline :: POSIXTime - } deriving Show - -PlutusTx.unstableMakeIsData ''VestingDatum - -{-# INLINABLE mkValidator #-} -mkValidator :: VestingDatum -> () -> ScriptContext -> Bool -mkValidator dat () ctx - | (beneficiary1 dat `elem` sigs) && (to (deadline dat) `contains` range) = True - | (beneficiary2 dat `elem` sigs) && (from (1 + deadline dat) `contains` range) = True - | otherwise = False - where - info :: TxInfo - info = scriptContextTxInfo ctx - - sigs :: [PubKeyHash] - sigs = txInfoSignatories info - - range :: POSIXTimeRange - range = txInfoValidRange info - -data Vesting -instance Scripts.ValidatorTypes Vesting where - type instance DatumType Vesting = VestingDatum - type instance RedeemerType Vesting = () - -typedValidator :: Scripts.TypedValidator Vesting -typedValidator = Scripts.mkTypedValidator @Vesting - $$(PlutusTx.compile [|| mkValidator ||]) - $$(PlutusTx.compile [|| wrap ||]) - where - wrap = Scripts.wrapValidator @VestingDatum @() - -validator :: Validator -validator = Scripts.validatorScript typedValidator - -scrAddress :: Ledger.Address -scrAddress = scriptAddress validator - -data GiveParams = GiveParams - { gpBeneficiary :: !PubKeyHash - , gpDeadline :: !POSIXTime - , gpAmount :: !Integer - } deriving (Generic, ToJSON, FromJSON, ToSchema) - -type VestingSchema = - Endpoint "give" GiveParams - .\/ Endpoint "grab" () - -give :: AsContractError e => GiveParams -> Contract w s e () -give gp = do - pkh <- pubKeyHash <$> ownPubKey - let dat = VestingDatum - { beneficiary1 = gpBeneficiary gp - , beneficiary2 = pkh - , deadline = gpDeadline gp - } - tx = mustPayToTheScript dat $ Ada.lovelaceValueOf $ gpAmount gp - ledgerTx <- submitTxConstraints typedValidator tx - void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s" - (gpAmount gp) - (show $ gpBeneficiary gp) - (show $ gpDeadline gp) - -grab :: forall w s e. AsContractError e => Contract w s e () -grab = do - now <- currentTime - pkh <- pubKeyHash <$> ownPubKey - utxos <- utxoAt scrAddress - let utxos1 = Map.filter (isSuitable $ \dat -> beneficiary1 dat == pkh && now <= deadline dat) utxos - utxos2 = Map.filter (isSuitable $ \dat -> beneficiary2 dat == pkh && now > deadline dat) utxos - logInfo @String $ printf "found %d gift(s) to grab" (Map.size utxos1 P.+ Map.size utxos2) - unless (Map.null utxos1) $ do - let orefs = fst <$> Map.toList utxos1 - lookups = Constraints.unspentOutputs utxos1 P.<> - Constraints.otherScript validator - tx :: TxConstraints Void Void - tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] P.<> - mustValidateIn (to now) - void $ submitTxConstraintsWith @Void lookups tx - unless (Map.null utxos2) $ do - let orefs = fst <$> Map.toList utxos2 - lookups = Constraints.unspentOutputs utxos2 P.<> - Constraints.otherScript validator - tx :: TxConstraints Void Void - tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] P.<> - mustValidateIn (from now) - void $ submitTxConstraintsWith @Void lookups tx - where - isSuitable :: (VestingDatum -> Bool) -> TxOutTx -> Bool - isSuitable p o = case txOutDatumHash $ txOutTxOut o of - Nothing -> False - Just h -> case Map.lookup h $ txData $ txOutTxTx o of - Nothing -> False - Just (Datum e) -> maybe False p $ PlutusTx.fromData e - -endpoints :: Contract () VestingSchema Text () -endpoints = (give' `select` grab') >> endpoints - where - give' = endpoint @"give" >>= give - grab' = endpoint @"grab" >> grab - -mkSchemaDefinitions ''VestingSchema - -mkKnownCurrencies [] diff --git a/code/week03/src/Week03/Solution2.hs b/code/week03/src/Week03/Solution2.hs deleted file mode 100644 index 041f123..0000000 --- a/code/week03/src/Week03/Solution2.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Week03.Solution2 where - -import Control.Monad hiding (fmap) -import Data.Aeson (ToJSON, FromJSON) -import Data.Map as Map -import Data.Text (Text) -import Data.Void (Void) -import GHC.Generics (Generic) -import Plutus.Contract -import qualified PlutusTx -import PlutusTx.Prelude hiding (Semigroup(..), unless) -import Ledger hiding (singleton) -import Ledger.Constraints as Constraints -import qualified Ledger.Typed.Scripts as Scripts -import Ledger.Ada as Ada -import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema) -import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions) -import Playground.Types (KnownCurrency (..)) -import Prelude (IO, Semigroup (..), Show (..), String) -import Text.Printf (printf) - -{-# INLINABLE mkValidator #-} -mkValidator :: PubKeyHash -> POSIXTime -> () -> ScriptContext -> Bool -mkValidator pkh s () ctx = - traceIfFalse "beneficiary's signature missing" checkSig && - traceIfFalse "deadline not reached" checkDeadline - where - info :: TxInfo - info = scriptContextTxInfo ctx - - checkSig :: Bool - checkSig = pkh `elem` txInfoSignatories info - - checkDeadline :: Bool - checkDeadline = from s `contains` txInfoValidRange info - -data Vesting -instance Scripts.ValidatorTypes Vesting where - type instance DatumType Vesting = POSIXTime - type instance RedeemerType Vesting = () - -typedValidator :: PubKeyHash -> Scripts.TypedValidator Vesting -typedValidator p = Scripts.mkTypedValidator @Vesting - ($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode p) - $$(PlutusTx.compile [|| wrap ||]) - where - wrap = Scripts.wrapValidator @POSIXTime @() - -validator :: PubKeyHash -> Validator -validator = Scripts.validatorScript . typedValidator - -scrAddress :: PubKeyHash -> Ledger.Address -scrAddress = scriptAddress . validator - -data GiveParams = GiveParams - { gpBeneficiary :: !PubKeyHash - , gpDeadline :: !POSIXTime - , gpAmount :: !Integer - } deriving (Generic, ToJSON, FromJSON, ToSchema) - -type VestingSchema = - Endpoint "give" GiveParams - .\/ Endpoint "grab" () - -give :: AsContractError e => GiveParams -> Contract w s e () -give gp = do - let p = gpBeneficiary gp - d = gpDeadline gp - tx = mustPayToTheScript d $ Ada.lovelaceValueOf $ gpAmount gp - ledgerTx <- submitTxConstraints (typedValidator p) tx - void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s" - (gpAmount gp) - (show $ gpBeneficiary gp) - (show $ gpDeadline gp) - -grab :: forall w s e. AsContractError e => Contract w s e () -grab = do - now <- currentTime - pkh <- pubKeyHash <$> ownPubKey - utxos <- Map.filter (isSuitable now) <$> utxoAt (scrAddress pkh) - if Map.null utxos - then logInfo @String $ "no gifts available" - else do - let orefs = fst <$> Map.toList utxos - lookups = Constraints.unspentOutputs utxos <> - Constraints.otherScript (validator pkh) - tx :: TxConstraints Void Void - tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] <> - mustValidateIn (from now) - ledgerTx <- submitTxConstraintsWith @Void lookups tx - void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ "collected gifts" - where - isSuitable :: POSIXTime -> TxOutTx -> Bool - isSuitable now o = case txOutDatumHash $ txOutTxOut o of - Nothing -> False - Just h -> case Map.lookup h $ txData $ txOutTxTx o of - Nothing -> False - Just (Datum e) -> case PlutusTx.fromData e of - Nothing -> False - Just d -> d <= now - -endpoints :: Contract () VestingSchema Text () -endpoints = (give' `select` grab') >> endpoints - where - give' = endpoint @"give" >>= give - grab' = endpoint @"grab" >> grab - -mkSchemaDefinitions ''VestingSchema - -mkKnownCurrencies []