Merge pull request #54 from mlabs-haskell/sam/list-nft

Add listing contract, add test, restructure slightly

Author: samuelWilliams99

index.d.ts

@@ -1,5 +1,7 @@
 export function callMarketPlaceBuy(config: Config, args: BuyNftArgs):
     Promise<void>
+export function callMarketPlaceSell(config: Config, args: SellArgs):
+    Promise<void>
 export function callMarketPlaceListNft(config: Config):
     Promise<Array<NftListing>>
 /**
@@ -46,6 +48,11 @@ export type BuyNftArgs = {
 
 }
 
+export type SellArgs = {
+    tokenCS: string,
+    tokenName: string
+}
+
 export type FetchNftArgs = Input
 
 export type NftCollectionArgs = {

src/Seabug/CallContract.purs

@@ -4,6 +4,7 @@ module Seabug.CallContract
   , callMarketPlaceBuy
   , callMarketPlaceFetchNft
   , callMarketPlaceListNft
+  , callMarketPlaceSell
   , callMint
   ) where
 
@@ -34,6 +35,7 @@ import Contract.Value
 import Control.Monad.Error.Class (throwError)
 import Control.Promise (Promise)
 import Control.Promise as Promise
+import Data.Bifunctor (lmap)
 import Data.BigInt (BigInt)
 import Data.BigInt as BigInt
 import Data.Log.Level (LogLevel(..))
@@ -50,6 +52,7 @@ import Seabug.Contract.CnftMint (mintCnft)
 import Seabug.Contract.Common (NftResult)
 import Seabug.Contract.MarketPlaceFetchNft (marketPlaceFetchNft)
 import Seabug.Contract.MarketPlaceListNft (marketPlaceListNft)
+import Seabug.Contract.MarketPlaceSell (marketPlaceSell)
 import Seabug.Contract.Mint (mintWithCollection)
 import Seabug.Metadata.Share (unShare)
 import Seabug.Metadata.Types (SeabugMetadata(SeabugMetadata))
@@ -134,6 +137,19 @@ callMarketPlaceListNft cfg = Promise.fromAff do
   listnft <- runContract contractConfig (marketPlaceListNft cfg.projectId)
   pure $ buildNftList contractConfig.networkId <$> listnft
 
+-- | Calls Seabugs marketPlaceSell and takes care of converting data types.
+-- | Returns a JS promise.
+callMarketPlaceSell
+  :: ContractConfiguration -> SellArgs -> Effect (Promise Unit)
+callMarketPlaceSell cfg args = Promise.fromAff do
+  contractConfig <- liftEither $ buildContractConfig cfg
+  sellArgs <- liftEither $ buildSellArgs args
+  runContract contractConfig do
+    txHash <- marketPlaceSell sellArgs
+    log $ "Waiting for confirmation of sell transaction: " <> show txHash
+    awaitTxConfirmed txHash
+    log $ "Sell transaction confirmed: " <> show txHash
+
 -- | Configuation needed to call contracts from JS.
 type ContractConfiguration =
   { serverHost :: String
@@ -202,6 +218,11 @@ type MintArgs =
   , price :: BigInt -- Natural
   }
 
+type SellArgs =
+  { tokenCS :: String
+  , tokenName :: String
+  }
+
 buildContractConfig
   :: ContractConfiguration -> Either Error (ConfigParams ())
 buildContractConfig cfg = do
@@ -382,6 +403,14 @@ buildMintArgs
       }
   pure (mintCnftParams /\ mintParams)
 
+buildSellArgs :: SellArgs -> Either Error (CurrencySymbol /\ TokenName)
+buildSellArgs { tokenCS, tokenName } = lmap error do
+  cs <- note "Failed to convert to currency symbol" $ mkCurrencySymbol =<<
+    hexToByteArray tokenCS
+  tn <- note "Failed to convert to token name" $ mkTokenName =<< hexToByteArray
+    tokenName
+  pure (cs /\ tn)
+
 buildTransactionInput :: TransactionInputOut -> Either Error TransactionInput
 buildTransactionInput input = do
   transactionId <-

src/Seabug/Contract/Buy.purs

@@ -22,7 +22,7 @@ import Plutus.Types.Transaction (UtxoM)
 import Seabug.Contract.Util
   ( ReturnBehaviour(..)
   , SeabugTxData
-  , minAdaOnlyUTxOValue
+  , minUTxOValue
   , mkChangeNftIdTxData
   , modify
   , seabugTxToMarketTx
@@ -54,15 +54,15 @@ mkBuyTxData nftData mScriptUtxos = do
 
     shareToSubtract :: BigInt -> BigInt
     shareToSubtract v
-      | v < minAdaOnlyUTxOValue = zero
+      | v < minUTxOValue = zero
       | otherwise = v
 
     filterLowValue
       :: BigInt
       -> (Value.Value -> TxConstraints Void Void)
       -> TxConstraints Void Void
     filterLowValue v t
-      | v < minAdaOnlyUTxOValue = mempty
+      | v < minUTxOValue = mempty
       | otherwise = t (Value.lovelaceValueOf v)
 
     authorShare = getShare $ toBigInt nftCollection.authorShare

src/Seabug/Contract/MarketPlaceListNft.purs

@@ -17,7 +17,7 @@ import Control.Parallel (parTraverse)
 import Data.Array (catMaybes, mapMaybe)
 import Data.Map as Map
 import Seabug.Contract.Common (NftResult)
-import Seabug.Contract.Util (minAdaOnlyUTxOValue)
+import Seabug.Contract.Util (minUTxOValue)
 import Seabug.MarketPlace (marketplaceValidatorAddr)
 import Seabug.Metadata (getFullSeabugMetadataWithBackoff)
 import Seabug.Types (MarketplaceDatum(MarketplaceDatum))
@@ -51,6 +51,6 @@ marketPlaceListNft projectId = do
         -- I put too low. The old nfts are caught above because their
         -- metadata won't be parsed.
         guard $ (unwrap metadata.seabugMetadata # _.ownerPrice) >=
-          (Natural.fromBigInt' minAdaOnlyUTxOValue)
+          (Natural.fromBigInt' minUTxOValue)
         pure { input, output, metadata }
   pure $ catMaybes withMetadata

src/Seabug/Contract/MarketPlaceSell.purs

@@ -0,0 +1,64 @@
+module Seabug.Contract.MarketPlaceSell
+  ( marketPlaceSell
+  ) where
+
+import Contract.Prelude
+
+import Contract.Address (getWalletAddress)
+import Contract.Monad (Contract, liftedE, liftedM)
+import Contract.PlutusData (toData)
+import Contract.ScriptLookups as Lookups
+import Contract.Transaction (TransactionHash, balanceAndSignTxE, submit)
+import Contract.TxConstraints as Constraints
+import Contract.Utxos (utxosAt)
+import Contract.Value
+  ( CurrencySymbol
+  , TokenName
+  , Value
+  , singleton
+  , valueOf
+  )
+import Data.BigInt (fromInt)
+import Effect.Exception (throw)
+import Seabug.MarketPlace (marketplaceValidator)
+import Seabug.Types (MarketplaceDatum(..))
+
+-- | Mint the self-governed NFT for the given collection.
+marketPlaceSell
+  :: forall (r :: Row Type)
+   . CurrencySymbol /\ TokenName
+  -> Contract r TransactionHash
+marketPlaceSell (curr /\ tn) = do
+  addr <- liftedM "Cannot get address" getWalletAddress
+  utxos <- liftedM "Cannot get user utxos" $ utxosAt addr
+  marketplaceValidator' <- unwrap <$> marketplaceValidator
+
+  let
+    hasToken :: Value -> Boolean
+    hasToken v = valueOf v curr tn == fromInt 1
+
+    callerHasToken :: Boolean
+    callerHasToken = any (unwrap >>> _.amount >>> hasToken) $ unwrap utxos
+
+    nftValue :: Value
+    nftValue = singleton curr tn one
+
+    lookups :: Lookups.ScriptLookups Void
+    lookups = Lookups.unspentOutputs (unwrap utxos)
+
+    constraints :: Constraints.TxConstraints Void Void
+    constraints =
+      Constraints.mustPayToScript marketplaceValidator'.validatorHash
+        ( wrap $ toData $ MarketplaceDatum $
+            { getMarketplaceDatum: curr /\ tn }
+        )
+        nftValue
+
+  unless callerHasToken $ liftEffect $ throw "Missing token"
+
+  unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints
+  signedTx <- liftedE $ balanceAndSignTxE unbalancedTx
+  transactionHash <- submit signedTx
+  log $ "Sell transaction successfully submitted with hash: " <> show
+    transactionHash
+  pure transactionHash

src/Seabug/Contract/Mint.purs

@@ -7,14 +7,12 @@ module Seabug.Contract.Mint
 import Contract.Prelude
 
 import Contract.Address
-  ( getNetworkId
-  , ownPaymentPubKeyHash
-  , ownStakePubKeyHash
-  , payPubKeyHashBaseAddress
+  ( ownPaymentPubKeyHash
+  , getWalletAddress
   )
 import Contract.AuxiliaryData (setTxMetadata)
 import Contract.Chain (currentSlot, currentTime)
-import Contract.Monad (Contract, liftContractE, liftContractM, liftedE, liftedM)
+import Contract.Monad (Contract, liftContractE, liftedE, liftedM)
 import Contract.PlutusData (toData)
 import Contract.ScriptLookups as Lookups
 import Contract.Scripts (validatorHash)
@@ -28,13 +26,16 @@ import Contract.Value
   , scriptCurrencySymbol
   , singleton
   )
-import Seabug.Contract.Util (getSeabugMetadata)
+import Seabug.Contract.Util
+  ( ReturnBehaviour(ToMarketPlace)
+  , getSeabugMetadata
+  , payBehaviour
+  )
 import Seabug.Lock (mkLockScript)
 import Seabug.MarketPlace (marketplaceValidator)
 import Seabug.MintingPolicy as MintingPolicy
 import Seabug.Types
   ( LockDatum(..)
-  , MarketplaceDatum(..)
   , MintAct(..)
   , MintParams(..)
   , NftCollection(..)
@@ -44,23 +45,22 @@ import Seabug.Types
 
 mintWithCollectionTest
   :: forall (r :: Row Type)
-   . CurrencySymbol /\ TokenName
+   . ReturnBehaviour
+  -> CurrencySymbol /\ TokenName
   -> MintParams
   -> ( Constraints.TxConstraints Void Void
        -> Contract r (Constraints.TxConstraints Void Void)
      )
   -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName) /\ NftData)
 mintWithCollectionTest
+  retBehaviour
   (collectionNftCs /\ collectionNftTn)
   ( MintParams
       { price, lockLockup, lockLockupEnd, authorShare, daoShare }
   )
   modConstraints = do
   owner <- liftedM "Cannot get PaymentPubKeyHash" ownPaymentPubKeyHash
-  ownerStake <- liftedM "Cannot get StakePubKeyHash" ownStakePubKeyHash
-  networkId <- getNetworkId
-  addr <- liftContractM "Cannot get user address" $
-    payPubKeyHashBaseAddress networkId owner ownerStake
+  addr <- liftedM "Cannot get address" getWalletAddress
   utxos <- liftedM "Cannot get user utxos" $ utxosAt addr
   marketplaceValidator' <- unwrap <$> marketplaceValidator
   lockingScript <- mkLockScript collectionNftCs lockLockup lockLockupEnd
@@ -95,11 +95,8 @@ mintWithCollectionTest
     constraints = mconcat
       [ Constraints.mustMintValueWithRedeemer (wrap $ toData $ MintToken nft)
           nftValue
-      , Constraints.mustPayToScript marketplaceValidator'.validatorHash
-          ( wrap $ toData $ MarketplaceDatum
-              { getMarketplaceDatum: curr /\ tn }
-          )
-          nftValue
+      , payBehaviour retBehaviour marketplaceValidator'.validatorHash
+          (curr /\ tn)
       , Constraints.mustPayToScript lockingScriptHash
           ( wrap $ toData $ LockDatum
               { sgNft: curr
@@ -127,7 +124,7 @@ mintWithCollection'
    . CurrencySymbol /\ TokenName
   -> MintParams
   -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName) /\ NftData)
-mintWithCollection' c p = mintWithCollectionTest c p pure
+mintWithCollection' c p = mintWithCollectionTest ToMarketPlace c p pure
 
 -- | Mint the self-governed NFT for the given collection.
 mintWithCollection

src/Seabug/Contract/Util.purs

@@ -1,11 +1,12 @@
 module Seabug.Contract.Util
-  ( SeabugTxData
-  , ReturnBehaviour(..)
-  , minAdaOnlyUTxOValue
+  ( ReturnBehaviour(..)
+  , SeabugTxData
+  , getSeabugMetadata
+  , minUTxOValue
   , mkChangeNftIdTxData
   , modify
+  , payBehaviour
   , seabugTxToMarketTx
-  , getSeabugMetadata
   ) where
 
 import Contract.Prelude
@@ -61,6 +62,7 @@ import Seabug.Types
   , NftData(..)
   , NftId
   )
+import Types.Scripts (ValidatorHash)
 import Types.Transaction (TransactionInput)
 
 type SeabugTxData =
@@ -78,6 +80,22 @@ modify fn t = wrap (fn (unwrap t))
 
 data ReturnBehaviour = ToMarketPlace | ToCaller
 
+payBehaviour
+  :: ReturnBehaviour
+  -> ValidatorHash
+  -> (Value.CurrencySymbol /\ Value.TokenName)
+  -> TxConstraints Void Void
+payBehaviour ToCaller _ _ = mempty -- Balancing will return the token to the caller
+payBehaviour ToMarketPlace valHash asset =
+  mustPayToScript
+    valHash
+    ( Datum $ toData $
+        MarketplaceDatum { getMarketplaceDatum: asset }
+    )
+    ( Value.singleton (fst asset) (snd asset) one <> Value.lovelaceValueOf
+        minUTxOValue
+    )
+
 -- | Build and submit a transaction involving a given nft, specifying
 -- | if the nft should be sent to the current user or the marketplace.
 seabugTxToMarketTx
@@ -106,22 +124,11 @@ seabugTxToMarketTx name retBehaviour mkTxData nftData = do
       [ ScriptLookups.typedValidatorLookups $ wrap marketplaceValidator'
       , ScriptLookups.validator marketplaceValidator'.validator
       ]
-    newNftValue =
-      Value.singleton (fst txData.newAsset) (snd txData.newAsset) one
 
     constraints :: TxConstraints Void Void
     constraints = txData.constraints
       <> mustSpendScriptOutput txData.inputUtxo unitRedeemer
-      <>
-        case retBehaviour of
-          ToMarketPlace ->
-            mustPayToScript
-              valHash
-              ( Datum $ toData $
-                  MarketplaceDatum { getMarketplaceDatum: txData.newAsset }
-              )
-              newNftValue
-          ToCaller -> mempty -- Balancing will return the token to the caller
+      <> payBehaviour retBehaviour valHash txData.newAsset
 
   txDatumsRedeemerTxIns <- liftedE $ mkUnbalancedTx lookups constraints
   metadata <- liftContractE $ getSeabugMetadata
@@ -208,8 +215,8 @@ mkChangeNftIdTxData name act mapNft (NftData nftData) mScriptUtxos = do
     , newNft: newNft
     }
 
-minAdaOnlyUTxOValue :: BigInt
-minAdaOnlyUTxOValue = BigInt.fromInt 2_000_000
+minUTxOValue :: BigInt
+minUTxOValue = BigInt.fromInt 2_000_000
 
 -- | Set metadata on the transaction for the given NFT
 getSeabugMetadata

test/Contract/Buy.purs

@@ -27,7 +27,7 @@ import Seabug.Contract.Util
   ( ReturnBehaviour(..)
   , SeabugTxData
   , getSeabugMetadata
-  , minAdaOnlyUTxOValue
+  , minUTxOValue
   , modify
   )
 import Seabug.MarketPlace (marketplaceValidatorAddr)
@@ -366,7 +366,7 @@ buyerMarketplaceUtxoAssert
 assertPaymentUtxo
   :: String -> Address -> BigInt -> PostBuyTestData -> Contract () Unit
 assertPaymentUtxo name addr payment { txData: { oldAsset } }
-  | payment < minAdaOnlyUTxOValue = pure unit
+  | payment < minUTxOValue = pure unit
   | otherwise =
       assertContract (name <> " did not have payment utxo with datum")
         =<< isJust