diff --git a/cabal.project b/cabal.project index 5a62f64..3e1db0f 100644 --- a/cabal.project +++ b/cabal.project @@ -26,7 +26,7 @@ packages: source-repository-package type: git location: https://github.com/Plutonomicon/plutarch-plutus - tag: 8cc0a4ca3ed494a79fe019c72173b369cd26cb84 + tag: fd7d1c1fc173542f952f19272554027183659dd6 subdir: . plutarch-ledger-api diff --git a/flake.lock b/flake.lock index 92986f2..a3cf015 100644 --- a/flake.lock +++ b/flake.lock @@ -2537,17 +2537,17 @@ "pre-commit-hooks": "pre-commit-hooks" }, "locked": { - "lastModified": 1737578147, - "narHash": "sha256-zQ0qv9e3Gy6Myn8wx+geJtCL5L2qJlpruSbWmrgyLOE=", + "lastModified": 1738185013, + "narHash": "sha256-lU2JF9KYvzEPfVLHdLkrM1hTTuc9NYi2hQPFnLDm2d8=", "owner": "Plutonomicon", "repo": "plutarch-plutus", - "rev": "8cc0a4ca3ed494a79fe019c72173b369cd26cb84", + "rev": "fd7d1c1fc173542f952f19272554027183659dd6", "type": "github" }, "original": { "owner": "Plutonomicon", "repo": "plutarch-plutus", - "rev": "8cc0a4ca3ed494a79fe019c72173b369cd26cb84", + "rev": "fd7d1c1fc173542f952f19272554027183659dd6", "type": "github" } }, diff --git a/flake.nix b/flake.nix index 5d99781..1c7c2ab 100644 --- a/flake.nix +++ b/flake.nix @@ -31,7 +31,7 @@ }; plutarch = { - url = "github:Plutonomicon/plutarch-plutus/8cc0a4ca3ed494a79fe019c72173b369cd26cb84"; + url = "github:Plutonomicon/plutarch-plutus/fd7d1c1fc173542f952f19272554027183659dd6"; }; }; diff --git a/nix/project.nix b/nix/project.nix index 9d4a8a3..23b8ab5 100644 --- a/nix/project.nix +++ b/nix/project.nix @@ -2,7 +2,7 @@ let sha256map = { - "https://github.com/Plutonomicon/plutarch-plutus"."8cc0a4ca3ed494a79fe019c72173b369cd26cb84" = "sha256-zQ0qv9e3Gy6Myn8wx+geJtCL5L2qJlpruSbWmrgyLOE="; + "https://github.com/Plutonomicon/plutarch-plutus"."fd7d1c1fc173542f952f19272554027183659dd6" = "sha256-lU2JF9KYvzEPfVLHdLkrM1hTTuc9NYi2hQPFnLDm2d8="; }; modules = [{ }]; diff --git a/src/plutarch-onchain-lib/lib/Plutarch/Core/Integrity.hs b/src/plutarch-onchain-lib/lib/Plutarch/Core/Integrity.hs new file mode 100644 index 0000000..01277f2 --- /dev/null +++ b/src/plutarch-onchain-lib/lib/Plutarch/Core/Integrity.hs @@ -0,0 +1,39 @@ +module Cardano.Core.Integrity ( + pisScriptCredential, + pisPubKeyCredential, + pdeserializeCredential, +) where + +import Plutarch.Core.List +import Plutarch.Prelude + +-- | Check that a data-encoded Credential is a ScriptCredential. +-- This does not guarantee that the data-encoded term is structurally a valid Credential. +-- So this should only be used if the data-encoded term is known to be a Credential. +-- If the term is obtained from relevant fields of the ScriptContext or TxInfo, then this check is safe +-- because the ledger guarantees the structural validity of the Credential. +pisScriptCredential :: Term s (PAsData PCredential) -> Term s PBool +pisScriptCredential cred = (pfstBuiltin # (pasConstr # pforgetData cred)) #== 1 + +-- | Check if the provided data-encoded Credential is a PubKeyCredential. +-- This does not guarantee that the data-encoded term is structurally a valid Credential. +-- So this should only be used if the data-encoded term is known to be a Credential. +-- If the term is obtained from relevant fields of the ScriptContext or TxInfo, then this check is safe +-- because the ledger guarantees the structural validity of the Credential. +pisPubKeyCredential :: Term s (PAsData PCredential) -> Term s PBool +pisPubKeyCredential cred = (pfstBuiltin # (pasConstr # pforgetData cred)) #== 0 + +-- | Check if the provided data-encoded term has the expected builtin data representation of a credential. +pdeserializeCredential :: Term s (PAsData PCredential) -> Term s (PAsData PCredential) +pdeserializeCredential term = + plet (pasConstr # pforgetData term) $ \constrPair -> + plet (pfstBuiltin # constrPair) $ \constrIdx -> + pif (plengthBS # (pasByteStr # (pheadSingleton # (psndBuiltin # constrPair))) #== 28) + ( + pcond + [ ( constrIdx #== 0 , term) + , ( constrIdx #== 1 , term) + ] + (ptraceInfoError "Invalid credential") + ) + perror diff --git a/src/plutarch-onchain-lib/lib/Plutarch/Core/PByteString.hs b/src/plutarch-onchain-lib/lib/Plutarch/Core/PByteString.hs index c9fc8ba..7e0d877 100644 --- a/src/plutarch-onchain-lib/lib/Plutarch/Core/PByteString.hs +++ b/src/plutarch-onchain-lib/lib/Plutarch/Core/PByteString.hs @@ -18,7 +18,7 @@ import Plutarch.Prelude -- | Checks if a tokenName is prefixed by a certain ByteString pisPrefixedWith :: ClosedTerm (PTokenName :--> PByteString :--> PBool) pisPrefixedWith = plam $ \tn prefix -> - pmatch (pto tn) $ \(PDataNewtype tnBS) -> pisPrefixOf # prefix # pfromData tnBS + pisPrefixOf # prefix # pto tn -- | Checks if the first ByteString is a prefix of the second pisPrefixOf :: ClosedTerm (PByteString :--> PByteString :--> PBool) diff --git a/src/plutarch-onchain-lib/lib/Plutarch/Core/Time.hs b/src/plutarch-onchain-lib/lib/Plutarch/Core/Time.hs index e38dafc..62a3120 100644 --- a/src/plutarch-onchain-lib/lib/Plutarch/Core/Time.hs +++ b/src/plutarch-onchain-lib/lib/Plutarch/Core/Time.hs @@ -8,16 +8,16 @@ module Plutarch.Core.Time ( pvalidityRangeStart, pvalidityRangeEnd, ptoCustomFiniteRangeH, - pisFinite + pisFinite, ) where import GHC.Generics (Generic) -import Plutarch.Core.Data (pnonew) import Plutarch.LedgerApi.V3 (PExtended (PFinite), PInterval (..), PLowerBound (PLowerBound), PPosixTime (..), - PUpperBound (PUpperBound)) + PUpperBound (PUpperBound), unPPosixTime) import Plutarch.Monadic qualified as P import Plutarch.Prelude +import Plutarch.Unsafe (punsafeCoerce) type PPosixTimeRange = PInterval PPosixTime @@ -37,50 +37,56 @@ instance DerivePlutusType PPosixFiniteRange where -- Errors if the provided time range is not finite. ptoFiniteRange :: Term s (PPosixTimeRange :--> PPosixFiniteRange) ptoFiniteRange = phoistAcyclic $ plam $ \timeRange -> P.do - timeRangeF <- pletFields @'["from", "to"] timeRange - PLowerBound lb <- pmatch timeRangeF.from - PFinite ((pfield @"_0" #) -> start) <- pmatch (pfield @"_0" # lb) - PUpperBound ub <- pmatch timeRangeF.to - PFinite ((pfield @"_0" #) -> end) <- pmatch (pfield @"_0" # ub) - pcon $ PPosixFiniteRange { from = start, to = end } + PInterval lowerBound upperBound <- pmatch timeRange + PLowerBound lb _ <- pmatch lowerBound + PFinite start <- pmatch lb + PUpperBound ub _ <- pmatch upperBound + PFinite end <- pmatch ub + pcon $ PPosixFiniteRange { from = pfromData start, to = pfromData end } -- | Get the start time of a 'PPosixTimeRange'. -- Errors if the start time is not finite. pvalidityRangeStart :: Term s (PPosixTimeRange :--> PAsData PInteger) pvalidityRangeStart = phoistAcyclic $ plam $ \timeRange -> P.do - PInterval ((pfield @"from" #) -> startTime) <- pmatch timeRange - PLowerBound lb <- pmatch startTime - PFinite ((pfield @"_0" #) -> posixTime) <- pmatch (pfield @"_0" # lb) - pmatch posixTime $ \(PPosixTime pt) -> pmatch pt $ \(PDataNewtype t) -> t + interval <- pmatch timeRange + let startTime = pinteral'from interval + --PInterval ((pfield @"from" #) -> startTime) <- pmatch timeRange + PLowerBound lb _ <- pmatch startTime + PFinite posixTime <- pmatch lb + punsafeCoerce $ pto posixTime -- | Get the end time of a 'PPosixTimeRange'. -- Errors if the end time is not finite. pvalidityRangeEnd :: Term s (PPosixTimeRange :--> PAsData PInteger) pvalidityRangeEnd = phoistAcyclic $ plam $ \timeRange -> P.do - PInterval ((pfield @"to" #) -> to_) <- pmatch timeRange - PUpperBound ub <- pmatch to_ - PFinite ((pfield @"_0" #) -> posixTime) <- pmatch (pfield @"_0" # ub) - pmatch posixTime $ \(PPosixTime pt) -> pmatch pt $ \(PDataNewtype t) -> t + interval <- pmatch timeRange + let to_ = pinteral'to interval + PUpperBound ub _ <- pmatch to_ + PFinite posixTime <- pmatch ub + punsafeCoerce $ pto posixTime -- | Extract the start and end times from a 'PPosixTimeRange' as Integers -- and return them as a pair via CPS. -- Errors if the start or end time is not finite. ptoCustomFiniteRangeH :: Term s PPosixTimeRange -> TermCont @r s (Term s PInteger, Term s PInteger) ptoCustomFiniteRangeH timeRange = do - timeRangeF <- pletFieldsC @'["from", "to"] timeRange - PLowerBound lb <- pmatchC timeRangeF.from - PFinite ((pfield @"_0" #) -> start) <- pmatchC (pfield @"_0" # lb) - PUpperBound ub <- pmatchC timeRangeF.to - PFinite ((pfield @"_0" #) -> end) <- pmatchC (pfield @"_0" # ub) - pure (pnonew $ pfromData start, pnonew $ pfromData end) + (PInterval from_ to_) <- pmatchC timeRange + PLowerBound lb _ <- pmatchC from_ + PFinite (pfromData -> start) <- pmatchC lb + PUpperBound ub _ <- pmatchC to_ + PFinite (pfromData -> end) <- pmatchC ub + pure (unPPosixTime start, unPPosixTime end) -- | Check if a 'PPosixTimeRange' is finite. pisFinite :: Term s (PInterval PPosixTime :--> PBool) pisFinite = plam $ \i -> - let isFiniteFrom = pmatch (pfield @"_0" # (pfield @"from" # i)) $ \case - PFinite _ -> pconstant True - _ -> pconstant False - isFiniteTo = pmatch (pfield @"_0" # (pfield @"to" # i)) $ \case - PFinite _ -> pconstant True - _ -> pconstant False - in pand' # isFiniteFrom # isFiniteTo + pmatch i $ \(PInterval start' end') -> + pmatch start' $ \(PLowerBound start _) -> + pmatch end' $ \(PUpperBound end _) -> + let isFiniteFrom = pmatch start $ \case + PFinite _ -> pconstant True + _ -> pconstant False + isFiniteTo = pmatch end $ \case + PFinite _ -> pconstant True + _ -> pconstant False + in pand' # isFiniteFrom # isFiniteTo diff --git a/src/plutarch-onchain-lib/lib/Plutarch/Core/Utils.hs b/src/plutarch-onchain-lib/lib/Plutarch/Core/Utils.hs index d4e5855..d6c2949 100644 --- a/src/plutarch-onchain-lib/lib/Plutarch/Core/Utils.hs +++ b/src/plutarch-onchain-lib/lib/Plutarch/Core/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} @@ -21,8 +22,6 @@ module Plutarch.Core.Utils( pisRewarding, ptryFromInlineDatum, pfromPDatum, - pnonew, - punnew, ppair, passert, pcheck, @@ -51,8 +50,6 @@ module Plutarch.Core.Utils( (#/=), pmapAndConvertList, pintToByteString, - punwrapPosixTime, - pwrapPosixTime, pdivCeil, pisScriptCredential, pisPubKeyCredential, @@ -62,12 +59,7 @@ module Plutarch.Core.Utils( import Data.Text qualified as T import Plutarch.Prelude -import Plutarch.LedgerApi.V3 (AmountGuarantees (Positive), - KeyGuarantees (Sorted), PAddress, - PCredential (..), PDatum, PMaybeData, - POutputDatum (POutputDatum), PPosixTime (..), - PPubKeyHash, PScriptHash, PScriptInfo, PTxInInfo, - PTxOut, PTxOutRef, PValue (..)) +import Plutarch.LedgerApi.V3 import Plutarch.Monadic qualified as P import Plutarch.Core.List (pheadSingleton) @@ -130,22 +122,6 @@ pfromPDatum :: Term s (PDatum :--> a) pfromPDatum = phoistAcyclic $ plam $ flip ptryFrom fst . pto --- Extract the inner type from a type which contains a `DataNewtype` --- ex. PPosixTime -> PInteger --- PPubKeyHash -> PByteString -pnonew :: forall {a :: PType} {b :: PType} {s :: S}. - ((PInner a :: PType) ~ (PDataNewtype b :: PType), PIsData b) => - Term s a -> Term s b -pnonew nt = pmatch (pto nt) $ \(PDataNewtype bs) -> pfromData bs - --- Extract the inner type from a `PDataNewType` --- ex. PDataNewtype PInteger -> PInteger --- PDataNewtype PByteString -> PByteString -punnew :: forall {b :: PType} {s :: S}. - PIsData b => - Term s (PDataNewtype b) -> Term s b -punnew nt = pmatch nt $ \(PDataNewtype bs) -> pfromData bs - ppair :: Term s a -> Term s b -> Term s (PPair a b) ppair a b = pcon (PPair a b) @@ -292,16 +268,19 @@ ptryOutputToAddress = phoistAcyclic $ ) # outs -ptryOwnOutput :: Term s (PBuiltinList (PAsData PTxOut) :--> PScriptHash :--> PTxOut) +ptryOwnOutput :: Term s (PBuiltinList (PAsData PTxOut) :--> PAsData PScriptHash :--> PTxOut) ptryOwnOutput = phoistAcyclic $ plam $ \outs target -> ( pfix #$ plam $ \self xs -> pelimList ( \txo txos -> - pmatch (pfield @"credential" # (pfield @"address" # txo)) $ \case - PPubKeyCredential _ -> (self # txos) - PScriptCredential ((pfield @"_0" #) -> vh) -> - pif (target #== vh) (pfromData txo) (self # txos) + pmatch (pfromData txo) $ \case + PTxOut {ptxOut'address} -> + pmatch ptxOut'address $ \addr -> + pmatch (paddress'credential addr) $ \case + PScriptCredential vh -> + pif (target #== vh) txo (self # txos) + PPubKeyCredential _ -> (self # txos) ) perror xs @@ -311,7 +290,10 @@ ptryOwnOutput = phoistAcyclic $ ptryOwnInput :: Term s (PBuiltinList (PAsData PTxInInfo) :--> PTxOutRef :--> PTxOut) ptryOwnInput = phoistAcyclic $ plam $ \inputs ownRef -> - precList (\self x xs -> pletFields @'["outRef", "resolved"] x $ \txInFields -> pif (ownRef #== txInFields.outRef) txInFields.resolved (self # xs)) (const perror) # inputs + precList (\self x xs -> + pmatch (pfromData x) $ \(PTxInInfo {ptxInInfo'outRef, ptxInInfo'resolved}) -> + pif (ownRef #== ptxInInfo'outRef) ptxInInfo'resolved (self # xs) + ) (const perror) # inputs ptxSignedByPkh :: Term s (PAsData PPubKeyHash :--> PBuiltinList (PAsData PPubKeyHash) :--> PBool) @@ -322,13 +304,16 @@ ptxSignedByPkh = pelem -} phasUTxO :: ClosedTerm - ( PAsData PTxOutRef + ( PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PBool ) phasUTxO = phoistAcyclic $ plam $ \oref inInputs -> - pany @PBuiltinList # plam (\input -> oref #== (pfield @"outRef" # input)) # inInputs + pany @PBuiltinList # plam (\input -> + pmatch (pfromData input) $ \ininfo -> + oref #== ptxInInfo'outRef ininfo + ) # inInputs pand'List :: [Term s PBool] -> Term s PBool pand'List ts' = @@ -381,12 +366,6 @@ pshowDigit = phoistAcyclic $ ] perror -punwrapPosixTime :: Term s (PAsData PPosixTime) -> Term s PInteger -punwrapPosixTime pt = pmatch (pfromData pt) $ \(PPosixTime pt') -> pmatch pt' $ \(PDataNewtype t) -> pfromData t - -pwrapPosixTime :: Term s PInteger -> Term s (PAsData PPosixTime) -pwrapPosixTime t = pdata $ pcon $ PPosixTime $ pcon $ PDataNewtype $ pdata t - pdivCeil :: Term s (PInteger :--> PInteger :--> PInteger) pdivCeil = phoistAcyclic $ plam $ diff --git a/src/plutarch-onchain-lib/lib/Plutarch/Core/Value.hs b/src/plutarch-onchain-lib/lib/Plutarch/Core/Value.hs index fa92747..49a505b 100644 --- a/src/plutarch-onchain-lib/lib/Plutarch/Core/Value.hs +++ b/src/plutarch-onchain-lib/lib/Plutarch/Core/Value.hs @@ -66,10 +66,9 @@ pfindCurrencySymbolsByTokenPrefix = phoistAcyclic $ plet (pisPrefixOf # prefix) $ \prefixCheck -> let mapVal = pto (pto value) isPrefixed = pfilter # plam (\csPair -> - pany # plam (\tkPair -> - pmatch (pto (pfromData $ pfstBuiltin # tkPair)) $ \(PDataNewtype tkn) -> - prefixCheck # pfromData tkn - ) # pto (pfromData (psndBuiltin # csPair)) + pany # plam (\tkPair -> + prefixCheck # pto (pfromData $ pfstBuiltin # tkPair) + ) # pto (pfromData (psndBuiltin # csPair)) ) # mapVal in pmap # pfstBuiltin # isPrefixed diff --git a/src/plutarch-onchain-lib/plutarch-onchain-lib.cabal b/src/plutarch-onchain-lib/plutarch-onchain-lib.cabal index 8a2e8dd..12c0aa1 100644 --- a/src/plutarch-onchain-lib/plutarch-onchain-lib.cabal +++ b/src/plutarch-onchain-lib/plutarch-onchain-lib.cabal @@ -99,7 +99,7 @@ test-suite plutarch-onchain-lib-tests , base , bytestring , cardano-crypto-class - , plutarch ==1.9.0 + , plutarch , plutarch-ledger-api , plutarch-onchain-lib , plutarch-testlib @@ -116,7 +116,7 @@ test-suite plutarch-onchain-lib-bench hs-source-dirs: test build-depends: , base - , plutarch ==1.9.0 + , plutarch , plutarch-ledger-api , plutarch-onchain-lib , plutarch-testlib