on-chain NFT governance module

mlabs/src/Mlabs/NFT/Api.hs

@@ -24,7 +24,7 @@ import Mlabs.NFT.Contract.CloseAuction (closeAuction)
 import Mlabs.NFT.Contract.Init (initApp)
 import Mlabs.NFT.Contract.Mint (mint)
 import Mlabs.NFT.Contract.OpenAuction (openAuction)
-import Mlabs.NFT.Contract.Query (queryContent, queryCurrentOwner, queryCurrentPrice, queryListNfts)
+import Mlabs.NFT.Contract.Query (queryContent, queryCurrentOwner, queryCurrentPrice, queryListNfts, queryNftAppInstance)
 import Mlabs.NFT.Contract.SetPrice (setPrice)
 import Mlabs.NFT.Types (
   AdminContract,
@@ -56,6 +56,7 @@ type NFTAppSchema =
     .\/ Endpoint "query-current-price" NftId
     .\/ Endpoint "query-list-nfts" ()
     .\/ Endpoint "query-content" Content
+    .\/ Endpoint "query-nft-app-instance" ()
     -- Auction endpoints
     .\/ Endpoint "auction-open" AuctionOpenParams
     .\/ Endpoint "auction-bid" AuctionBidParams
@@ -109,6 +110,7 @@ queryEndpointsList uT =
   , endpoint @"query-current-owner" (void . queryCurrentOwner uT)
   , endpoint @"query-list-nfts" (void . const (queryListNfts uT))
   , endpoint @"query-content" (void . queryContent uT)
+  , endpoint @"query-nft-app-instance" (void . const (queryNftAppInstance uT))
   ]
 
 -- | List of admin endpoints.

mlabs/src/Mlabs/NFT/Contract/Aux.hs

@@ -9,8 +9,10 @@ module Mlabs.NFT.Contract.Aux (
   getDatumsTxsOrderedFromAddr,
   getGovHead,
   getNftAppSymbol,
+  getNftGovSymbol,
   getNftDatum,
   getNftHead,
+  getHead,
   getScriptAddrUtxos,
   getsNftDatum,
   getUId,
@@ -54,6 +56,7 @@ import Ledger.Value as Value (unAssetClass, valueOf)
 import Mlabs.Plutus.Contract (readDatum')
 
 import Mlabs.NFT.Governance.Types
+import Mlabs.NFT.Governance.Validation
 import Mlabs.NFT.Types
 import Mlabs.NFT.Validation
 
@@ -107,7 +110,7 @@ getHead uT = do
   where
     containUniqueToken = (/= 0) . flip assetClassValueOf uT . (^. ciTxOutValue) . fst
 
--- | Get the  Symbol
+-- | Get the Nft Symbol
 getNftAppSymbol :: UniqueToken -> GenericContract NftAppSymbol
 getNftAppSymbol uT = do
   lHead <- getHead uT
@@ -123,6 +126,22 @@ getNftAppSymbol uT = do
   where
     err = Contract.throwError "Could not establish App Symbol."
 
+-- | Get the Governance Symbol
+getNftGovSymbol :: UniqueToken -> GenericContract GovAppSymbol
+getNftGovSymbol uT = do
+  lHead <- getGovHead . govScrAddress $ uT
+  case lHead of
+    Nothing -> err
+    Just headInfo -> do
+      let uTCS = fst . unAssetClass $ uT
+      let val = filter (\x -> x /= uTCS && x /= "") . symbols $ pi'CITxO headInfo ^. ciTxOutValue
+      case val of
+        [x] -> pure $ GovAppSymbol x
+        [] -> Contract.throwError "Could not establish App Symbol. Does it exist in the HEAD?"
+        _ -> Contract.throwError "Could not establish App Symbol. Too many symbols to distinguish from."
+  where
+    err = Contract.throwError "Could not establish App Symbol."
+
 -- | Get the ChainIndexTxOut at an address.
 getAddrValidUtxos :: UniqueToken -> GenericContract (Map.Map TxOutRef (ChainIndexTxOut, ChainIndexTx))
 getAddrValidUtxos ut = do

mlabs/src/Mlabs/NFT/Contract/Gov/Query.hs

@@ -11,7 +11,7 @@ import Data.Text (Text)
 
 import Plutus.Contract (Contract)
 import Plutus.Contract qualified as Contract
-import PlutusTx.Prelude hiding (mconcat, mempty, (<>))
+import PlutusTx.Prelude hiding (mconcat, mempty, (<>), (==))
 
 import Ledger (
   PubKeyHash,
@@ -56,7 +56,7 @@ querryCurrentStake uT _ = do
       where
         findPoint = \case
           (x1 : xs) ->
-            if pi'data x1 == node
+            if pi'data x1 Hask.== node
               then pure x1
               else findPoint xs
           _ -> Contract.throwError "GOV node not found"

mlabs/src/Mlabs/NFT/Contract/Init.hs

@@ -6,6 +6,7 @@ module Mlabs.NFT.Contract.Init (
 ) where
 
 import Control.Monad (void)
+import Data.Map qualified as Map
 import Data.Monoid (Last (..))
 import Data.Text (Text, pack)
 import Text.Printf (printf)
@@ -14,9 +15,9 @@ import Text.Printf (printf)
 import Prelude (mconcat, (<>))
 import Prelude qualified as Hask
 
-import Ledger (AssetClass, scriptCurrencySymbol)
+import Ledger (AssetClass, getCardanoTxId, scriptCurrencySymbol)
 import Ledger.Constraints qualified as Constraints
-import Ledger.Typed.Scripts (validatorHash)
+import Ledger.Typed.Scripts (validatorHash, validatorScript)
 import Ledger.Value as Value (singleton)
 import Plutus.Contract (Contract, mapError, ownPubKeyHash)
 import Plutus.Contract qualified as Contract
@@ -33,10 +34,10 @@ import Plutus.V1.Ledger.Value (TokenName (..), assetClass, assetClassValue)
 import PlutusTx.Prelude hiding (mconcat, (<>))
 
 import Mlabs.Data.LinkedList (LList (..))
-import Mlabs.NFT.Contract.Aux (toDatum)
+import Mlabs.NFT.Contract.Aux (getGovHead, toDatum)
 import Mlabs.NFT.Governance.Types (GovAct (..), GovDatum (..), GovLHead (..))
-import Mlabs.NFT.Governance.Validation (govMintPolicy, govScrAddress, govScript)
-import Mlabs.NFT.Types (GenericContract, InitParams (..), MintAct (..), NftAppInstance (..), NftAppSymbol (..), NftListHead (..))
+import Mlabs.NFT.Governance.Validation (GovManage, govMintPolicy, govScrAddress, govScript)
+import Mlabs.NFT.Types (GenericContract, InitParams (..), MintAct (..), NftAppInstance (..), NftAppSymbol (..), NftListHead (..), PointInfo (..))
 import Mlabs.NFT.Validation (DatumNft (..), NftTrade, asRedeemer, curSymbol, mintPolicy, txPolicy, txScrAddress)
 
 {- | The App Symbol is written to the Writter instance of the Contract to be
@@ -79,24 +80,44 @@ createListHead InitParams {..} = do
           govHeadDatum :: GovDatum = govHeadInit
           govHeadPolicy = govMintPolicy appInstance
           govScr = govScript uniqueToken
+          govValidScr = validatorScript . govScript $ uniqueToken
           govProofTokenValue = Value.singleton (scriptCurrencySymbol govHeadPolicy) emptyTokenName 1
           govInitRedeemer = asRedeemer InitialiseGov
 
-          -- NFT App Head
-          (lookups, tx) =
+          -- NFT Gov Head
+          (lookups1, tx1) =
+            ( Constraints.typedValidatorLookups govScr
+            , Constraints.mustPayToTheScript govHeadDatum uniqueTokenValue
+            )
+
+      ledgerTx1 <- Contract.submitTxConstraintsWith @GovManage lookups1 tx1
+      void $ Contract.awaitTxConfirmed $ getCardanoTxId ledgerTx1
+      headPoint' <- getGovHead $ appInstance'Governance appInstance
+      headPoint <- case headPoint' of
+        Nothing -> Contract.throwError @Text "Couldn't find head" -- This should never happen
+        Just h -> return h
+
+      Contract.logInfo @Hask.String $ printf "Head is found %s" (Hask.show headPoint)
+
+      let -- NFT App Head
+          (lookups2, tx2) =
             ( mconcat
                 [ Constraints.typedValidatorLookups (txPolicy uniqueToken)
+                , Constraints.otherScript govValidScr
+                , Constraints.unspentOutputs $ Map.singleton (pi'TOR headPoint) (pi'CITxO headPoint)
                 , Constraints.mintingPolicy headPolicy
                 , Constraints.mintingPolicy govHeadPolicy
                 ]
             , mconcat
                 [ Constraints.mustPayToTheScript headDatum (proofTokenValue <> uniqueTokenValue)
+                , Constraints.mustSpendScriptOutput (pi'TOR headPoint) govInitRedeemer
                 , Constraints.mustPayToOtherScript (validatorHash govScr) (toDatum govHeadDatum) (govProofTokenValue <> uniqueTokenValue)
                 , Constraints.mustMintValueWithRedeemer initRedeemer proofTokenValue
                 , Constraints.mustMintValueWithRedeemer govInitRedeemer govProofTokenValue
                 ]
             )
-      void $ Contract.submitTxConstraintsWith @NftTrade lookups tx
+      ledgerTx2 <- Contract.submitTxConstraintsWith @NftTrade lookups2 tx2
+      void $ Contract.awaitTxConfirmed $ getCardanoTxId ledgerTx2
       Contract.logInfo @Hask.String $ printf "Forged Script Head & Governance Head for %s" (Hask.show appInstance)
       return appInstance
 

mlabs/src/Mlabs/NFT/Contract/Query.hs

@@ -8,14 +8,15 @@ module Mlabs.NFT.Contract.Query (
   QueryContract,
   queryContent,
   queryContentLog,
+  queryNftAppInstance,
 ) where
 
 import Control.Monad ()
 
 import Data.Monoid (Last (..), mconcat)
 import Data.Text (Text)
 import GHC.Base (join)
-import Mlabs.NFT.Contract.Aux (getDatumsTxsOrdered, getNftDatum, getsNftDatum, hashData)
+import Mlabs.NFT.Contract.Aux (getDatumsTxsOrdered, getHead, getNftDatum, getsNftDatum, hashData)
 import Mlabs.NFT.Types (
   Content,
   DatumNft (..),
@@ -26,6 +27,7 @@ import Mlabs.NFT.Types (
   QueryResponse (..),
   UniqueToken,
   UserWriter,
+  head'appInstance,
  )
 import Plutus.Contract (Contract)
 import Plutus.Contract qualified as Contract
@@ -110,3 +112,24 @@ queryContent uT content = do
 -- | Log of status of a content. Used in testing as well.
 queryContentLog :: Content -> QueryResponse -> String
 queryContentLog content info = mconcat ["Content status of: ", show content, " is: ", show info]
+
+queryNftAppInstance :: UniqueToken -> QueryContract QueryResponse
+queryNftAppInstance uT = do
+  head' <- getHead uT
+  res <- case head' of
+    Nothing -> return Nothing
+    Just (PointInfo listHead _ _ _) ->
+      do
+        let status = head'appInstance listHead
+        tell' $ QueryNftAppInstance . Just $ status
+        log $ QueryNftAppInstance . Just $ status
+        return $ Just status
+  wrap res
+  where
+    wrap = return . QueryNftAppInstance
+    tell' s = Contract.tell (Last . Just . Right $ s)
+    log status = Contract.logInfo @String $ queryNftAppInstanceLog uT status
+
+-- | Log of status of a content. Used in testing as well.
+queryNftAppInstanceLog :: UniqueToken -> QueryResponse -> String
+queryNftAppInstanceLog uT symbol = mconcat ["NftAppInstance of the app standing at UniqueToken: ", show uT, " is: ", show symbol]

mlabs/src/Mlabs/NFT/Governance/Types.hs

@@ -5,13 +5,15 @@ module Mlabs.NFT.Governance.Types (
   GovLList,
   GovDatum (..),
   LList (..),
+  GovAppSymbol (..),
 ) where
 
+import Data.OpenApi.Schema qualified as OpenApi
+import Ledger (CurrencySymbol)
 import Mlabs.Data.LinkedList (LList (..))
 import Mlabs.NFT.Types (UserId)
-import Prelude qualified as Hask
-
 import PlutusTx qualified
+import Prelude qualified as Hask
 
 import Data.Aeson (FromJSON, ToJSON)
 import GHC.Generics (Generic)
@@ -29,6 +31,17 @@ data GovLHead = GovLHead
 PlutusTx.unstableMakeIsData ''GovLHead
 PlutusTx.makeLift ''GovLHead
 
+newtype GovAppSymbol = GovAppSymbol {gov'symbol :: CurrencySymbol}
+  deriving stock (Hask.Show, Generic, Hask.Eq, Hask.Ord)
+  deriving anyclass (ToJSON, FromJSON, OpenApi.ToSchema)
+
+PlutusTx.unstableMakeIsData ''GovAppSymbol
+PlutusTx.makeLift ''GovAppSymbol
+
+instance Eq GovAppSymbol where
+  {-# INLINEABLE (==) #-}
+  (GovAppSymbol a) == (GovAppSymbol a') = a == a'
+
 instance Eq GovLHead where
   {-# INLINEABLE (==) #-}
   (GovLHead a b) == (GovLHead a' b') = a == a' && b == b'
@@ -59,8 +72,6 @@ data GovAct
     MintGov -- Gov Token is added / update on list, and as many xGov tokens are created and relelased.
   | -- | Use as Proof
     Proof -- Token is used as proof and must be returned unchanged to the application
-  | -- | Use as Proof and Burn
-    ProofAndBurn -- Token is used as proof and must be burned in totality.
   | -- | Initialises the Governance List at the given location
     InitialiseGov
   deriving stock (Hask.Show, Generic, Hask.Eq)