Skip to content

Instantly share code, notes, and snippets.

@ilap

ilap/Playground.hs

Created October 3, 2021 10:43
Show Gist options
  • Save ilap/61eeace74f6b6afabd6d74ec3b638335 to your computer and use it in GitHub Desktop.
Save ilap/61eeace74f6b6afabd6d74ec3b638335 to your computer and use it in GitHub Desktop.
Download ZIP
Plutus Playground Smart Contract
Raw
Playground.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DerivingVia #-}
module Fracada where
import Prelude (IO, String, show, Show)
import Control.Monad hiding (fmap)
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Void (Void)
import Plutus.Contract as Contract
import qualified PlutusTx
import PlutusTx.IsData
import PlutusTx.Prelude hiding (Semigroup(..), unless)
import Ledger hiding (singleton)
import Ledger.Constraints as Constraints
import qualified Ledger.Typed.Scripts as Scripts
import Ledger.Scripts
import qualified Ledger.Contexts as Validation
import Ledger.Value as Value
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema, NonEmpty(..) )
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions, ensureKnownCurrencies)
import Playground.Types (KnownCurrency (..))
import Plutus.Trace.Emulator as Emulator
import Prelude (Semigroup (..))
import Text.Printf (printf)
import GHC.Generics (Generic)
import Data.Aeson (ToJSON, FromJSON)
import Wallet.Emulator.Wallet
import qualified Data.ByteString.Base16 as Base16
import qualified Cardano.Api as Script
import qualified Cardano.Api.Shelley as Script
import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR))
import Codec.Serialise (decode, encode, serialise)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString
import qualified Data.ByteString.Short as SBS
import qualified Data.Text as Text
import Plutus.V1.Ledger.Api (plutusDatumEnvelopeType, plutusRedeemerEnvelopeType,
plutusScriptEnvelopeType)
import Plutus.V1.Ledger.Scripts as Export
import Plutus.V1.Ledger.Api (toData)
import Plutus.V1.Ledger.Bytes (fromHex)
import PlutusTx.Builtins as Builtins
import qualified Data.Attoparsec.ByteString.Char8 as PBC
import qualified Data.Attoparsec.ByteString.Lazy as PLB
import qualified Data.ByteString.Base16.Lazy as B16
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.ByteArray.Encoding
import Cardano.Ledger.Alonzo.Data
import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR))
import Codec.Serialise (decode, encode, serialise)
import Data.Aeson (encode, decode, eitherDecode)
import Data.Aeson.Extras
import qualified Cardano.Ledger.Alonzo.Data as Alonzo
import Ouroboros.Consensus.Shelley.Eras (StandardCrypto, StandardAlonzo)
import qualified Cardano.Crypto as Crypto
import qualified Cardano.Crypto.Hash.Class as Crypto
data FractionNFTDatum = FractionNFTDatum {
tokensClass :: AssetClass,
totalFractions :: Integer,
owner :: PubKeyHash
} deriving (Generic, Show)
PlutusTx.makeLift ''FractionNFTDatum
PlutusTx.makeIsDataIndexed ''FractionNFTDatum [('FractionNFTDatum,0)]
-- | Datum and redeemer parameter types for fractioning script
data Fractioning
instance Scripts.ValidatorTypes Fractioning where
type instance RedeemerType Fractioning = ()
type instance DatumType Fractioning = FractionNFTDatum
{-# INLINABLE datumToData #-}
datumToData :: (FromData a) => Datum -> Maybe a
datumToData datum = fromBuiltinData (getDatum datum)
{-# INLINABLE dataHash #-}
dataHash :: Builtins.BuiltinData -> Builtins.BuiltinByteString
dataHash =
toBuiltin
. Script.serialiseToRawBytes
. Script.hashScriptData
. Script.fromPlutusData
. builtinDataToData
{-# INLINABLE fractionNftValidator #-}
fractionNftValidator :: AssetClass -> FractionNFTDatum -> () -> ScriptContext -> Bool
fractionNftValidator nftAsset FractionNFTDatum{tokensClass, totalFractions, owner} _ ctx =
let
txInfo = scriptContextTxInfo ctx
-- extract signer of this transaction, assume is only one
[sig] = txInfoSignatories txInfo
forgedTokens = assetClassValueOf (txInfoMint txInfo) tokensClass
nftIsLocked = assetClassValueOf ( Validation.valueLockedBy txInfo (Validation.ownHash ctx)) nftAsset == 1
in
if (nftIsLocked) then
let
(_, ownDatumHash) = ownHashes ctx
[(_,newDatum)] = filter (\(h,d) -> h /= ownDatumHash) $ txInfoData txInfo
Just FractionNFTDatum{totalFractions=newTotalFractions} = datumToData newDatum
tokensMinted = forgedTokens == totalFractions
in
-- check fractions input = 0 output = n
-- owner is same
-- tokens minted
traceIfFalse "NFT already fractioned" (totalFractions == 0) &&
traceIfFalse "NFT not fractioned" (newTotalFractions > 0) &&
traceIfFalse "Tokens not minted" tokensMinted &&
traceIfFalse "Owner not the same" (owner == sig)
else
let
tokensBurnt = forgedTokens == negate totalFractions && forgedTokens /= 0
nftIsPaidToOwner = assetClassValueOf (Validation.valuePaidTo txInfo sig ) nftAsset == 1
in
traceIfFalse "NFT not paid to owner" nftIsPaidToOwner &&
traceIfFalse "Tokens not burn" tokensBurnt
fractionNftValidatorInstance :: AssetClass -> Scripts.TypedValidator Fractioning
fractionNftValidatorInstance asset = Scripts.mkTypedValidator @Fractioning
($$(PlutusTx.compile [|| fractionNftValidator ||])
`PlutusTx.applyCode`
PlutusTx.liftCode asset)
$$(PlutusTx.compile [|| wrap ||]) where
wrap = Scripts.wrapValidator @FractionNFTDatum @()
fractionNftValidatorHash :: AssetClass -> ValidatorHash
fractionNftValidatorHash = Scripts.validatorHash . fractionNftValidatorInstance
fractionValidatorScript :: AssetClass -> Validator
fractionValidatorScript = Scripts.validatorScript . fractionNftValidatorInstance
fractionNftValidatorAddress :: AssetClass -> Address
fractionNftValidatorAddress = Ledger.scriptAddress . fractionValidatorScript
{-# INLINABLE mintFractionTokens #-}
mintFractionTokens :: ValidatorHash -> AssetClass -> Integer -> TokenName -> () -> ScriptContext -> Bool
mintFractionTokens fractionNFTScript asset@( AssetClass (nftCurrency, nftToken)) numberOfFractions fractionTokenName _ ctx =
let
info = scriptContextTxInfo ctx
mintedAmount = case flattenValue (txInfoMint info) of
[(cs, fractionTokenName', amt)] | cs == ownCurrencySymbol ctx && fractionTokenName' == fractionTokenName -> amt
_ -> 0
in
if mintedAmount > 0 then
let
nftValue = valueOf (valueSpent info) nftCurrency nftToken
assetIsLocked = nftValue == 1
lockedByNFTfractionScript = valueLockedBy info fractionNFTScript
assetIsPaid = assetClassValueOf lockedByNFTfractionScript asset == 1
in
traceIfFalse "NFT not paid" assetIsPaid &&
traceIfFalse "NFT not locked already" assetIsLocked &&
traceIfFalse "wrong fraction tokens minted" ( mintedAmount == numberOfFractions)
else
let
-- extract signer of this transaction, assume is only one
[sig] = txInfoSignatories info
assetIsReturned = assetClassValueOf (Validation.valuePaidTo info sig ) asset == 1
in
traceIfFalse "Asset not returned" assetIsReturned &&
traceIfFalse "wrong fraction tokens burned" ( mintedAmount == negate numberOfFractions)
mintFractionTokensPolicy :: AssetClass -> Integer -> TokenName -> Scripts.MintingPolicy
mintFractionTokensPolicy asset numberOfFractions fractionTokenName = mkMintingPolicyScript $
$$(PlutusTx.compile [|| \validator' asset' numberOfFractions' fractionTokenName' -> Scripts.wrapMintingPolicy $ mintFractionTokens validator' asset' numberOfFractions' fractionTokenName' ||])
`PlutusTx.applyCode`
PlutusTx.liftCode ( fractionNftValidatorHash asset)
`PlutusTx.applyCode`
PlutusTx.liftCode asset
`PlutusTx.applyCode`
PlutusTx.liftCode numberOfFractions
`PlutusTx.applyCode`
PlutusTx.liftCode fractionTokenName
curSymbol :: AssetClass -> Integer -> TokenName -> CurrencySymbol
curSymbol asset numberOfFractions fractionTokenName = scriptCurrencySymbol $ mintFractionTokensPolicy asset numberOfFractions fractionTokenName
data ToFraction = ToFraction
{ nftAsset :: !AssetClass
, fractions :: !Integer
, fractionTokenName :: !TokenName
} deriving (Generic, ToJSON, FromJSON, ToSchema)
type FracNFTSchema =
Endpoint "1-lockNFT" AssetClass
.\/ Endpoint "2-fractionNFT" ToFraction
.\/ Endpoint "3-returnNFT" AssetClass
-- | Extract Datum of a given transaction output is possible
extractData :: ChainIndexTxOut -> Maybe FractionNFTDatum
extractData o = do
Datum d <- either (const Nothing) Just (_ciTxOutDatum o)
PlutusTx.fromBuiltinData d
lockNFT :: AssetClass -> Contract w FracNFTSchema Text ()
lockNFT nftAsset = do
-- pay nft to contract
pk <- Contract.ownPubKey
let
-- keep the nft and asset class in the datum,
-- we signal no fractioning yet with a 0 in the total fractions field
--datum =FractionNFTDatum{ tokensClass= nftAsset, totalFractions = 0, owner = "A096D51DA85C3EAABE2718BE7B59F51291979935AD77B8DEB4622FA3"}
datum =FractionNFTDatum{ tokensClass= nftAsset, totalFractions = 0, owner = pubKeyHash pk}
-- lock the nft and the datum into the fractioning contract
validator = fractionNftValidatorInstance nftAsset
tx = Constraints.mustPayToTheScript datum $ assetClassValue nftAsset 1
ledgerTx <- submitTxConstraints validator tx
void $ awaitTxConfirmed $ txId ledgerTx
Contract.logInfo @String $ printf "NFT locked"
fractionNFT :: ToFraction -> Contract w FracNFTSchema Text ()
fractionNFT ToFraction {nftAsset, fractions, fractionTokenName} = do
-- pay nft to contract
-- pay minted tokens back to signer
pkh <- pubKeyHash <$> Contract.ownPubKey
utxos <- utxosAt $ fractionNftValidatorAddress nftAsset
let
-- declare the NFT value
nftValue = assetClassValue nftAsset 1
-- find the UTxO that has the NFT we're looking for
-- Just utxo@(oref, _)
futxo = find (\(_,v) -> nftValue == txOutValue (toTxOut v)) $ Map.toList utxos
Just utxo@(oref, otx) = futxo
-- txDatumHash = txOutDatumHash $ txOutTxOut txout
-- Check the original datumHash and compare a newly created one
--find the minting script instance
mintingScript = mintFractionTokensPolicy nftAsset fractions fractionTokenName
-- define the value to mint (amount of tokens) and be paid to signer
currency = scriptCurrencySymbol mintingScript
tokensToMint = Value.singleton currency fractionTokenName fractions
payBackTokens = mustPayToPubKey pkh tokensToMint
-- value of NFT
valueToScript = assetClassValue nftAsset 1
-- keep the minted amount and asset class in the datum
--datum = Datum $ toBuiltinData FractionNFTDatum{ tokensClass= assetClass currency fractionTokenName, totalFractions = fractions, owner = pkh}
nftDatum = FractionNFTDatum{ tokensClass= assetClass currency fractionTokenName, totalFractions = fractions, owner = pkh }
nftData = toBuiltinData nftDatum
datum = Datum $ nftData
nftDatumHash = datumHash datum
-- Create a datum fieht f apartmentNft, 0, and the onwerpkh?
-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
newNftDatum = FractionNFTDatum{ tokensClass= nftAsset, totalFractions = 0, owner = "32323232323232323232323232323232323232323232323232323232"}
newNftData = toBuiltinData newNftDatum
newDatum = Datum $ newNftData
newHash = datumHash newDatum
-- CBOR.toStrictByteString $
--c = toCbor newDatum
dHash :: Datum -> DatumHash
dHash = DatumHash . dataHash . getDatum
hh = dHash newDatum
-- ##################################################################################################################################################
d = getDatum newDatum
b = builtinDataToData d
f = Script.fromPlutusData b
--aa = B16.decode "a096d51da85c3eaabe2718be7b59f51291979935ad77b8deb4622fa3"
--ts = toString "a096d51da85c3eaabe2718be7b59f51291979935ad77b8deb4622fa3"
--bss = concat [0xA0,0x96,0xD5,0x1D,0xA8,0x5C,0x3E,0xAA,0xBE,0x27,0x18,0xBE,0x7B,0x59,0xF5,0x12,0x91,0x97,0x99,0x35,0xAD,0x77,0xB8,0xDE,0xB4,0x62,0x2F,0xA3]
-- dbs = fromHexText "a096d51da85c3eaabe2718be7b59f51291979935ad77b8deb4622fa3"
-- sdb = Script.ScriptDataBytes aa --pkh
--genByteString :: [LB.ByteString] -> Crypto.ByteString
--genByteString bs = BSL.pack . bs
---[0xA0,0x96,0xD5,0x1D,0xA8,0x5C,0x3E,0xAA,0xBE,0x27,0x18,0xBE,0x7B,0x59,0xF5,0x12,0x91,0x97,0x99,0x35,0xAD,0x77,0xB8,0xDE,0xB4,0x62,0x2F,0xA3]
gen = Script.ScriptDataConstructor 0 [Script.ScriptDataConstructor 0 [Script.ScriptDataBytes "f", Script.ScriptDataBytes "apartmentNft"],
Script.ScriptDataNumber 0, Script.ScriptDataBytes "2222222222222222222222222222" ]
h = Script.hashScriptData f
hgen = Script.hashScriptData gen
hSData :: Script.ScriptData -> Script.Hash Script.ScriptData
hSData = Script.ScriptDataHash
. Alonzo.hashData
. (Script.toAlonzoData :: Script.ScriptData -> Alonzo.Data StandardAlonzo)
sa :: Script.ScriptData -> Alonzo.Data StandardAlonzo
sa = (Script.toAlonzoData :: Script.ScriptData -> Alonzo.Data StandardAlonzo)
-- hsa = sa h
h2 = hSData f -- Script.ScriptDataHash $ Alonzo.hashData (Script.toAlonzoData :: Script.ScriptData -> Alonzo.Data StandardAlonzo) h
s = Script.serialiseToRawBytes h
t = toBuiltin s
dh = DatumHash t
aaa = DatumHash $ toBuiltin . Script.serialiseToRawBytes . Script.hashScriptData . Script.fromPlutusData . builtinDataToData $ getDatum newDatum
--txDatumHash = txOutDatumHash $ txOutTxOut oref
hello :: PlutusTx.Prelude.BuiltinByteString
hello = "Hello World!"
pData = toData hello
-- print $ "Datum value: " <> encode (scriptDataToJson ScriptDataJsonDetailedSchema $ fromPlutusData pData)
datumToEncode = builtinDataToData $ getDatum datum
encoded = Data.Aeson.encode (Script.scriptDataToJson Script.ScriptDataJsonDetailedSchema $ Script.fromPlutusData datumToEncode)
--Script.ScriptDataJsonDetailedSchema res = Data.Aeson.decode encoded
--Left err -> failWith Nothing $ "Failed to decode script data (eitherDecode): " ++ err
--Right sDataJsonValue
--a = Script.ScriptDataJsonDetailedSchema encoded
--decoded = Data.Aeson.eitherDecode (Script.scriptDataFromJson Script.ScriptDataJsonDetailedSchema encoded)
--decode = Script.scriptDataFromJson $ Script.ScriptDataJsonDetailedSchema
-- alma = ToCBOR newNftDatum
-- utxoData = extractData otx
--alma = hashData
--ud = Datum $ utxoData
--uh = datumHash utxoData
--dt = datumToData utxoData
--utxoDataHash = dataHash dt
-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
--build the constraints and submit the transaction
validator = fractionValidatorScript nftAsset
lookups = Constraints.mintingPolicy mintingScript <>
Constraints.otherScript validator <>
Constraints.unspentOutputs ( Map.fromList [utxo] )
tx = Constraints.mustMintValue tokensToMint <>
Constraints.mustPayToOtherScript (fractionNftValidatorHash nftAsset) datum valueToScript <>
Constraints.mustSpendScriptOutput oref (Redeemer (toBuiltinData ())) <>
payBackTokens
--Contract.logInfo @String $ printf "####################################################################################"
--Contract.logInfo @String $ printf "getDatum newDatum %s" (show d)
--Contract.logInfo @String $ printf "builtinDataToData d %s" (show b)
--Contract.logInfo @String $ printf "Script.fromPlutusData b %s" (show f)
--Contract.logInfo @String $ printf "Generated data %s" (show gen)
--Contract.logInfo @String $ printf "Script.hashScriptData f %s" (show h)
--Contract.logInfo @String $ printf "Script.hashScriptData gen %s" (show hgen)
--Contract.logInfo @String $ printf "Script.serialiseToRawBytes h %s" (show s)
--Contract.logInfo @String $ printf "toBuiltin s %s" (show t)
--Contract.logInfo @String $ printf "DatumHash t %s" (show dh)
--Contract.logInfo @String $ printf "####################################################################################"
--Contract.logInfo @String $ printf "pData %s" (show pData)
Contract.logInfo @String $ printf "Show NFTDATIM %s" (show nftDatum)
Contract.logInfo @String $ printf "Show NFTDATA %s" (show nftData)
Contract.logInfo @String $ printf "Show NEWDATUM %s" (show datum)
Contract.logInfo @String $ printf "Show NEWHASH %s" (show nftDatumHash)
Contract.logInfo @String $ printf "Show TOENCODE %s" (show datumToEncode)
Contract.logInfo @String $ printf "Show ENCODED %s" (show encoded)
Contract.logInfo @String $ printf "Show GENERAT %s" (show gen)
--Contract.logInfo @String $ printf "Show UTXO HASH %s" (show newHash)
--Contract.logInfo @String $ printf "Show NEW HASH %s" (show nftDatumHash)
--Contract.logInfo @String $ printf "Show UTXO %s" (show futxo)
ledgerTx <- submitTxConstraintsWith @Void lookups tx
void $ awaitTxConfirmed $ txId ledgerTx
Contract.logInfo @String $ printf "forged %s" (show fractions)
sdata :: LB.ByteString -> Script.ScriptData
sdata sData = --do
-- let sData = Aeson.encode $ scriptDataToJson ScriptDataJsonDetailedSchema $ customRedeemerToScriptData myCusRedeem
case Data.Aeson.eitherDecode sData of
Left{} -> Contract.logInfo @String $ printf "forged %s" (sData)
Right sDataJsonValue ->
case Script.scriptDataFromJson Script.ScriptDataJsonDetailedSchema sDataJsonValue of
Left{} -> Contract.logInfo @String $ printf "forged %s" (sDataJsonValue)
Right sDataDecoded -> sDataDecoded
-- case Script.fromPlutusData sDataDecoded of
-- Left{} -> Contract.logInfo @String $ printf "forged %s" (sDataDecoded)
-- Right cusRedDecoded -> cusRedDecoded
returnNFT :: AssetClass -> Contract w FracNFTSchema Text ()
returnNFT nftAsset = do
-- pay nft to signer
-- burn tokens
pk <- Contract.ownPubKey
utxos <- utxosAt $ fractionNftValidatorAddress nftAsset
let
-- declare the NFT value
valueToWallet = assetClassValue nftAsset 1
-- find the UTxO that has the NFT we're looking for
utxos' = Map.filter (\v -> valueToWallet == txOutValue (toTxOut v)) utxos
(nftRef,nftTx) = head $ Map.toList utxos'
-- use the auxiliary extractData function to get the datum content
Just FractionNFTDatum {tokensClass, totalFractions } = extractData nftTx
-- declare the fractional tokens to burn
(_, fractionTokenName) = unAssetClass tokensClass
tokensCurrency = curSymbol nftAsset totalFractions fractionTokenName
tokensToBurn = Value.singleton tokensCurrency fractionTokenName $ negate totalFractions
-- build the constraints and submit
validator = fractionValidatorScript nftAsset
lookups = Constraints.mintingPolicy (mintFractionTokensPolicy nftAsset totalFractions fractionTokenName) <>
Constraints.otherScript validator <>
Constraints.unspentOutputs utxos'
tx = Constraints.mustMintValue tokensToBurn <>
Constraints.mustSpendScriptOutput nftRef ( Redeemer $ toBuiltinData () ) <>
Constraints.mustPayToPubKey (pubKeyHash pk) valueToWallet
ledgerTx <- submitTxConstraintsWith @Void lookups tx
void $ awaitTxConfirmed $ txId ledgerTx
Contract.logInfo @String $ printf "burnt %s" (show totalFractions)
endpoints :: Contract () FracNFTSchema Text ()
endpoints = forever
$ handleError logError
$ awaitPromise
$ lock' `select` fractionNFT' `select` burn'
where
lock' = endpoint @"1-lockNFT" $ lockNFT
fractionNFT' = endpoint @"2-fractionNFT" $ fractionNFT
burn' = endpoint @"3-returnNFT" $ returnNFT
mkSchemaDefinitions ''FracNFTSchema
-- The code below is related to Playground.
-- NFT to lock "f"."nft2Lock"
nftSymbol :: CurrencySymbol
nftSymbol = currencySymbol "f"
-- ^ "f" = 66
nftName :: TokenName
nftName = TokenName "apartmentNft"
nft :: KnownCurrency
nft = KnownCurrency (fromSymbol nftSymbol) "Token" ( nftName :| [])
-- Fractional NFTs "".
-- The fraction NFT's cyrrency symbol is generated as a parameterized script from:
-- - the mintingScript with the following parameters
-- - the lockable nft's asset class
-- - the fraction value and the
-- - fraction nft's name
cs :: AssetClass -> Integer -> TokenName -> CurrencySymbol
cs asset numberOfFractions fractionTokenName = scriptCurrencySymbol $ mintFractionTokensPolicy asset numberOfFractions fractionTokenName
nftAssetClass :: AssetClass
nftAssetClass = Value.assetClass nftSymbol nftName
fraction :: Integer
fraction = 100
fractionNftName :: TokenName
fractionNftName = TokenName "fractionalToken"
fractionSymbol :: CurrencySymbol
fractionSymbol = curSymbol nftAssetClass fraction fractionNftName
fractionNfts :: KnownCurrency
fractionNfts = KnownCurrency (fromSymbol fractionSymbol) "Token" (fractionNftName :| [])
mkKnownCurrencies ['nft, 'fractionNfts]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment