Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix onchain logic #5

Open
wants to merge 7 commits into
base: main
Choose a base branch
from
Open

Fix onchain logic #5

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
de778c1
Clean up CollectionMaker.hs
Feb 6, 2022
85d1707
Clean up Bounty.hs
Feb 6, 2022
8c895e5
Fix onchain logic so that it always evaluates
Feb 17, 2022
ffe6291
Rename getBountyDatum to findBountyDatum
Feb 17, 2022
196376b
Remove unused imports
Feb 17, 2022
f76f84d
Remove unused variables and fix shadowed variables
Feb 17, 2022
0118726
Make function names consistent
Feb 19, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
156 changes: 56 additions & 100 deletions src/Bounty.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -31,40 +31,22 @@ module Bounty where

import Control.Monad hiding (fmap)
import Data.Aeson (FromJSON, ToJSON)
import Data.List (intersect, union)
import qualified Data.Map as Map
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Void (Void)
import GHC.Generics (Generic)
import Ledger hiding (singleton)
import Ledger.Ada as Ada
import Ledger.Constraints as Constraints
import qualified Ledger.Contexts as Validation
import Ledger.Credential
import Ledger.Index as Index
import qualified Ledger.Typed.Scripts as Scripts
import Ledger.Value as Value
import Playground.Contract (NonEmpty (..), ToSchema,
ensureKnownCurrencies, printJson,
printSchemas, stage)
import Playground.TH (ensureKnownCurrencies, mkKnownCurrencies,
mkSchemaDefinitions)
import Playground.Types (KnownCurrency (..))
import Plutus.Contract as Contract
import qualified PlutusTx
import PlutusTx.IsData
import PlutusTx.Maybe
import PlutusTx.Prelude hiding (Semigroup (..), unless)
import Prelude (Semigroup (..), Show, String, show)
import Text.Printf (printf)
import Prelude (Show)

data Bounty = Bounty
{ expiration :: !POSIXTime,
voters :: ![PubKeyHash],
requiredVotes :: !Integer,
collectionMakerClass :: !AssetClass,
collectionToken :: !AssetClass
{ bExpiration :: !POSIXTime,
bVoters :: ![PubKeyHash],
bRequiredVotes :: !Integer,
bCollectionMakerClass :: !AssetClass,
bCollectionToken :: !AssetClass
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It's common practice to prefix record field names with data type initials. In this case one letter prefix is enough, however usually with several record data structures, two-letter prefixes are more common.

This has been one of the biggest issues with Record in Haskell. I think this particular variable scoping issue has been fixed in GHC 9.x, I've not tried it myself though so can't comment much on that.

}
deriving (Show, Generic, FromJSON, ToJSON)

Expand All @@ -82,8 +64,8 @@ PlutusTx.makeIsDataIndexed
PlutusTx.makeLift ''Destination

data Collection = Collection
{ votes :: ![PubKeyHash],
destination :: !Destination
{ cVotes :: ![PubKeyHash],
cDestination :: !Destination
}
deriving (Show, Generic, FromJSON, ToJSON)

Expand Down Expand Up @@ -121,23 +103,9 @@ instance Scripts.ValidatorTypes Bountying where

-- Datum Related Functions:

{-# INLINABLE collectionDatum #-}
collectionDatum :: TxInfo -> TxOut -> Maybe BountyDatum
collectionDatum txInfo o = do
dh <- txOutDatum o
Datum d <- findDatum dh txInfo
PlutusTx.fromBuiltinData d

{-# INLINABLE collectionMaker #-}
collectionMaker :: TxInfo -> TxOut -> Maybe BountyDatum
collectionMaker txInfo o = do
dh <- txOutDatum o
Datum d <- findDatum dh txInfo
PlutusTx.fromBuiltinData d

{-# INLINABLE potDatum #-}
potDatum :: TxInfo -> TxOut -> Maybe BountyDatum
potDatum txInfo o = do
{-# INLINABLE findBountyDatum #-}
findBountyDatum :: TxInfo -> TxOut -> Maybe BountyDatum
findBountyDatum txInfo o = do
dh <- txOutDatum o
Datum d <- findDatum dh txInfo
PlutusTx.fromBuiltinData d
Expand All @@ -150,31 +118,31 @@ collectionMinted ctx collectionAsset =
in assetClassValueOf mintVal collectionAsset

{-# INLINABLE assetContinues #-}
assetContinues :: ScriptContext -> [TxOut] -> AssetClass -> Bool
assetContinues ctx continuingOutputs asset =
assetContinues :: [TxOut] -> AssetClass -> Bool
assetContinues continuingOutputs asset =
sum [assetClassValueOf (txOutValue x) asset | x <- continuingOutputs] > 0

-- Voting Arithmetic Functions
{-# INLINABLE validateCollectionChange #-}
validateCollectionChange :: TxInfo -> [PubKeyHash] -> BountyDatum -> Maybe BountyDatum -> Bool
validateCollectionChange info voters before mafter = case mafter of
Just (CollectionDatum c) -> case before of
CollectionDatum k -> validateKeyChanges info voters (votes k) (votes c)
validateCollectionChange info voters votesBefore maybeDatumAfter = case maybeDatumAfter of
Just (CollectionDatum c) -> case votesBefore of
CollectionDatum k -> validateKeyChanges info voters (cVotes k) (cVotes c)
_ -> False
_ -> False

-- This need to reflect false when we don't have enough votes or if the votes are incorrect.
{-# INLINABLE solidCollection #-}
solidCollection :: Bounty -> Collection -> Bool
solidCollection b c =
let enoughVotes = (requiredVotes b) <= (length (votes c))
correctVotes = [a | a <- (votes c), elem a (voters b)] -- filterVotes (voters b) (votes c)
in length correctVotes == length (votes c)
let enoughVotes = (bRequiredVotes b) <= (length (cVotes c))
correctVotes = [a | a <- (cVotes c), elem a (bVoters b)] -- filterVotes (voters b) (votes c)
in length correctVotes == length (cVotes c)
&& enoughVotes

{-# INLINABLE correctCollection #-}
correctCollection :: TxOut -> Collection -> Bool
correctCollection o c = case (destination c) of
correctCollection o c = case (cDestination c) of
Person pkh -> case (addressCredential (txOutAddress o)) of
PubKeyCredential opkh -> pkh == opkh
_ -> False
Expand All @@ -184,56 +152,47 @@ correctCollection o c = case (destination c) of

-- We need to make sure that the spending path is correct for the PotDatum TxOut TODO
{-# INLINABLE validateUseOfPot #-}
validateUseOfPot :: Bounty -> TxOut -> Maybe BountyDatum -> Maybe BountyDatum -> Bool
validateUseOfPot bounty potTxOut mpot mcollection = case mpot of
Just m -> case mcollection of
Just (CollectionDatum c) ->
solidCollection bounty c
&& correctCollection potTxOut c
_ -> False
_ -> False
validateUseOfPot :: Bounty -> Maybe TxOut -> Maybe BountyDatum -> Maybe BountyDatum -> Bool
-- validateUseOfPot bounty mPotTxOut mpot mcollection = case mpot of
validateUseOfPot bounty (Just potTxOut) (Just _) (Just (CollectionDatum c)) =
solidCollection bounty c && correctCollection potTxOut c
validateUseOfPot _ _ _ _ = False
Copy link

@bjing bjing Feb 19, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I refactored this part so that it's clearer in that line 157 lists the case for which we want to run the validator logic. For all other cases, we evaluate to False straight away.

When we write it in nested style like the removed code above, it's can be less obvious what cases (branches) have been covered and what have not.


-- This needs to check that
-- - Only valid voters are counted
-- - All new voters have signed the tx.
{-# INLINABLE validateKeyChanges #-}
validateKeyChanges :: TxInfo -> [PubKeyHash] -> [PubKeyHash] -> [PubKeyHash] -> Bool
validateKeyChanges info voters before after =
let newVotes = [a | a <- after, elem a voters]
compVal = [a | a <- after, elem a before]
in compVal == before
validateKeyChanges info voters votesBefore votesAfter =
let newVotes = [a | a <- votesAfter, elem a voters]
compVal = [a | a <- votesAfter, elem a votesBefore]
in compVal == votesBefore
&& all (txSignedBy info) newVotes

-- High-Level Functions -- ehh lmao
{-# INLINABLE containsClass #-}
containsClass :: TxOut -> AssetClass -> Bool
containsClass o a = (assetClassValueOf (txOutValue o) a) > 0

{-# INLINABLE getOutput #-}
getOutput :: [TxOut] -> AssetClass -> TxOut
getOutput txOuts asset =
case [o | o <- txOuts, containsClass o asset] of
[x] -> x
_ -> traceError "Fail here."
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is the part where it doesn't return a TxOut, instead it calls traceError. If we don't always return a result, we should be returning a Maybe (or something similar) instead of bailing with traceError.

{-# INLINABLE findOutputForClass #-}
findOutputForClass :: AssetClass -> [TxOut] -> Maybe TxOut
findOutputForClass asset = find $ \o -> containsClass o asset
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The naming convention for getting a value (if possible) from a collection is find so I named it this way, it also corresponds with the find call in the implementation.


{-# INLINABLE containsPot #-}
containsPot :: TxInfo -> TxOut -> Bool
containsPot info o =
let d = potDatum info o
in case d of
Just PotDatum -> True
_ -> False
case findBountyDatum info o of
Copy link

@bjing bjing Feb 19, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Since Haskell is expression based, you don't need to assign value to a variable and then pattern match on that variable, you can directly pattern match on the value/expression.

Just PotDatum -> True
_ -> False

{-# INLINABLE getOutputPDatum #-}
getOutputPDatum :: TxInfo -> [TxOut] -> TxOut
getOutputPDatum info txOuts = case [o | o <- txOuts, containsPot info o] of
[x] -> x
_ -> traceError "Fail here."
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is the part where it doesn't return a TxOut, instead it calls traceError. If we don't always return a result, we need to return a maybe instead of bailing with traceError.

{-# INLINABLE findOutputPDatum #-}
findOutputPDatum :: TxInfo -> [TxOut] -> Maybe TxOut
findOutputPDatum info = find (containsPot info)

{-# INLINABLE startCollectionDatum #-}
startCollectionDatum :: Maybe BountyDatum -> Bool
startCollectionDatum md = case md of
Just (CollectionDatum c) -> length (votes c) == 0
Just (CollectionDatum c) -> length (cVotes c) == 0
_ -> False

{-# INLINABLE validMakerDatum #-}
Expand All @@ -252,15 +211,15 @@ validPotDatum md = case md of
-- - CollectionDatum value starts with an empty voter list.
-- -
{-# INLINABLE checkCreateCollection #-}
checkCreateCollection :: ScriptContext -> BountyDatum -> AssetClass -> AssetClass -> Bool
checkCreateCollection ctx collection makerAsset collectionAsset =
checkCreateCollection :: ScriptContext -> AssetClass -> AssetClass -> Bool
checkCreateCollection ctx makerAsset collectionAsset =
let txInfo = scriptContextTxInfo ctx
outputs = txInfoOutputs txInfo
txOuts = txInfoOutputs txInfo
continuingOutputs = getContinuingOutputs ctx
datumMaker = collectionMaker txInfo (getOutput outputs makerAsset)
datumBox = collectionDatum txInfo (getOutput outputs collectionAsset)
in assetContinues ctx continuingOutputs makerAsset
&& assetContinues ctx continuingOutputs collectionAsset
datumMaker = findOutputForClass makerAsset txOuts >>= findBountyDatum txInfo
datumBox = findOutputForClass collectionAsset txOuts >>= findBountyDatum txInfo
in assetContinues continuingOutputs makerAsset
&& assetContinues continuingOutputs collectionAsset
&& (collectionMinted ctx collectionAsset) == 1
&& startCollectionDatum datumBox
&& validMakerDatum datumMaker
Expand All @@ -271,10 +230,10 @@ checkCreateCollection ctx collection makerAsset collectionAsset =
checkVoteApplication :: ScriptContext -> AssetClass -> BountyDatum -> [PubKeyHash] -> Bool
checkVoteApplication ctx collectionAsset datum voters =
let txInfo = scriptContextTxInfo ctx
outputs = txInfoOutputs txInfo
txOuts = txInfoOutputs txInfo
continuingOutputs = getContinuingOutputs ctx
datumBox = collectionDatum txInfo (getOutput outputs collectionAsset)
in assetContinues ctx continuingOutputs collectionAsset
datumBox = findOutputForClass collectionAsset txOuts >>= findBountyDatum txInfo
in assetContinues continuingOutputs collectionAsset
&& validateCollectionChange txInfo voters datum datumBox

-- - Are there enough voters in the list
Expand All @@ -284,13 +243,10 @@ checkVoteApplication ctx collectionAsset datum voters =
checkSpending :: ScriptContext -> Bounty -> Bool
checkSpending ctx bounty =
let txInfo = scriptContextTxInfo ctx
txIns = txInfoInputs txInfo
outputs = txInfoOutputs txInfo
continuingOutputs = getContinuingOutputs ctx
datumBox = collectionDatum txInfo (getOutput outputs (collectionToken bounty))
potTxOut = getOutputPDatum txInfo outputs
potBox = potDatum txInfo potTxOut
txInValues = [txOutValue $ txInInfoResolved txIn | txIn <- txIns]
txOuts = txInfoOutputs txInfo
datumBox = findOutputForClass (bCollectionToken bounty) txOuts >>= findBountyDatum txInfo
potTxOut = findOutputPDatum txInfo txOuts
potBox = potTxOut >>= findBountyDatum txInfo
in validateUseOfPot bounty potTxOut potBox datumBox

-- We only can have one CollectionDatum/Token - We need to implement these - definitely.
Expand All @@ -300,10 +256,10 @@ checkSpending ctx bounty =
bountyScript :: Bounty -> BountyDatum -> BountyAction -> ScriptContext -> Bool
bountyScript bounty datum action ctx = case datum of
CollectionMaker -> case action of
CreateCollection c -> checkCreateCollection ctx datum (collectionMakerClass bounty) (collectionToken bounty)
CreateCollection _ -> checkCreateCollection ctx (bCollectionMakerClass bounty) (bCollectionToken bounty)
_ -> False
CollectionDatum c -> case action of
ApplyVote -> checkVoteApplication ctx (collectionMakerClass bounty) datum (voters bounty)
CollectionDatum _ -> case action of
ApplyVote -> checkVoteApplication ctx (bCollectionMakerClass bounty) datum (bVoters bounty)
SpendAction -> checkSpending ctx bounty
_ -> False
PotDatum -> case action of
Expand Down
30 changes: 4 additions & 26 deletions src/CollectionMaker.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -28,33 +28,11 @@

module CollectionMaker where

import Control.Monad hiding (fmap)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Map as Map
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Void (Void)
import GHC.Generics (Generic)
import Ledger hiding (singleton)
import Ledger.Ada as Ada
import Ledger.Constraints as Constraints
import qualified Ledger.Contexts as Validation
import Ledger.Index as Index
import qualified Ledger.Typed.Scripts as Scripts
import Ledger.Value as Value
import Playground.Contract (NonEmpty (..), ToSchema,
ensureKnownCurrencies, printJson,
printSchemas, stage)
import Playground.TH (ensureKnownCurrencies, mkKnownCurrencies,
mkSchemaDefinitions)
import Playground.Types (KnownCurrency (..))
import Plutus.Contract as Contract
import qualified PlutusTx
import PlutusTx.IsData
import PlutusTx.Maybe
import PlutusTx.Prelude hiding (Semigroup (..), unless)
import Prelude (Semigroup (..), Show, String, show)
import Text.Printf (printf)

{-# INLINABLE mkPolicy #-}
mkPolicy :: AssetClass -> BuiltinData -> ScriptContext -> Bool
Expand All @@ -64,18 +42,18 @@ mkPolicy asset _ ctx =
where
txInfo = scriptContextTxInfo ctx
txInValues = [txOutValue $ txInInfoResolved txIn | txIn <- txInfoInputs $ scriptContextTxInfo ctx]
txOuts = txInfoOutputs txInfo
nftValues = [assetClassValueOf val asset | val <- txInValues]
nftSum = sum nftValues
mintedAmount = case flattenValue (txInfoMint txInfo) of
[(cs, collectionTokenName, amt)] | cs == ownCurrencySymbol ctx -> amt
_ -> 0
[(cs, _, amt)] | cs == ownCurrencySymbol ctx -> amt
_ -> 0

policy :: AssetClass -> Scripts.MintingPolicy
policy asset =
mkMintingPolicyScript $
$$(PlutusTx.compile [||Scripts.wrapMintingPolicy . mkPolicy||])
`PlutusTx.applyCode` PlutusTx.liftCode asset
`PlutusTx.applyCode`
PlutusTx.liftCode asset
Copy link

@bjing bjing Feb 19, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't understand this formatting 🤷‍♂️ . However, setting it like this will stop this formatting from getting into every PR as noise. I've asked about this particular issue on IOG's tech channel, this seems to be stylish-haskell's fault, well, I guess we need to live with it.


curSymbol :: AssetClass -> CurrencySymbol
curSymbol asset = scriptCurrencySymbol $ policy asset