From d9688313197224774367709998754a7fffc60cba Mon Sep 17 00:00:00 2001 From: rsoeldner Date: Wed, 18 Oct 2023 21:26:32 +0200 Subject: [PATCH 1/6] wip --- pact-core.cabal | 1 + pact-core/Pact/Core/StableEncoding.hs | 74 +++++++++++++++++++++++++++ 2 files changed, 75 insertions(+) create mode 100644 pact-core/Pact/Core/StableEncoding.hs diff --git a/pact-core.cabal b/pact-core.cabal index ffb3f0c74..c172aa1d2 100644 --- a/pact-core.cabal +++ b/pact-core.cabal @@ -106,6 +106,7 @@ library Pact.Core.ModRefs Pact.Core.Interpreter Pact.Core.Environment + Pact.Core.StableEncoding -- Syntax modules Pact.Core.Syntax.ParseTree diff --git a/pact-core/Pact/Core/StableEncoding.hs b/pact-core/Pact/Core/StableEncoding.hs new file mode 100644 index 000000000..0cfaf912d --- /dev/null +++ b/pact-core/Pact/Core/StableEncoding.hs @@ -0,0 +1,74 @@ +-- | + +module Pact.Core.StableEncoding +where + +import Pact.Core.PactValue + +newtype StableEncoding a + = StableEncoding a + + +instance J.Encode (StableEncoding Literal) where + build (StableEncoding lit) = case lit of + LString t -> undefined + LInteger i -> undefined + LDecimal d -> undefined + LUnit -> undefined + LBool b -> undefined + {-# INLINABLE build #-} + +instance J.Encode (StableEncoding (Guard FullyQualifiedName PactValue)) where + build (StableEncoding g) = case g of + GKetset ks -> undefined + GKetSetRef ksn -> undefined + GUserGuard -> undefined + GCapabilityGuard cg -> undefined + GModuleGuard mg -> undefined + {-# INLINABLE build #-} + +instance J.Encode (StableEncoding (CapabilityGuard FullyQualifiedName PactValue)) where + build (StableEncoding (CapabilityGuard name args)) = undefined + {-# INLINABLE build #-} + +instance J.Encode (StableEncoding ModuleGuards) where + build (StableEncoding (ModuleGuard mod name)) = undefined + {-# INLINABLE build #-} + +instance J.Encode (StableEncoding (UserGuard FullyQualifiedName PactValue)) where + build (StableEncoding (UserGuard fun args)) = undefined + {-# INLINABLE build #-} + +instance J.Encode (StableEncoding KeySetName) where + build (StableEncoding (KeySetName ksn)) = undefined + {-# INLINABLE build #-} + +instance J.Encode (StableEncoding (KeySet FullyQualifiedName)) where + build (StableEncoding (KeySet keys predFun)) = undefined + {-# INLINABLE build #-} + +instance J.Encode (StableEncoding (KSPredicate FullyQualifiedName)) where + build (StableEncoding ksp) = case ksp of + KeysAll -> undefined + Keys2 -> undefined + KeysAny -> undefined + {-# INLINABLE build #-} + + + +instance J.Encode (StableEncoding PublicKeyText) where + build (StableEncoding (PublicKeyText pkt)) = undefined + {-# INLINABLE build #-} + + + +instance J.Encode (StableEncoding PactValue) where + build (StableEncoding pv) = case pv of + PLiteral lit J.build (StableEncoding lit) + PList l -> J.build (J.Array (StableEncoding <$> v)) + PGuard g -> undefined + PObject o -> undefined + PModRef mr -> undefined + PCapToken ct -> undefined + PTime pt -> undefined + {-# INLINABLE build #-} From 9dfb546efe9e6b9e2c045900a9fdcbc26dcd6e54 Mon Sep 17 00:00:00 2001 From: rsoeldner Date: Thu, 19 Oct 2023 15:21:28 +0200 Subject: [PATCH 2/6] add `StableEncoding` --- pact-core.cabal | 1 + pact-core/Pact/Core/IR/Eval/CEK.hs | 7 +- pact-core/Pact/Core/Pacts/Types.hs | 17 --- pact-core/Pact/Core/StableEncoding.hs | 183 +++++++++++++++++++++----- 4 files changed, 156 insertions(+), 52 deletions(-) diff --git a/pact-core.cabal b/pact-core.cabal index 3da9b2364..cda3e50ea 100644 --- a/pact-core.cabal +++ b/pact-core.cabal @@ -51,6 +51,7 @@ common pact-core-common , exceptions , array , pact-json + , scientific ghc-options: -Wall -Werror -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints ghc-prof-options: -fprof-auto -fprof-auto-calls diff --git a/pact-core/Pact/Core/IR/Eval/CEK.hs b/pact-core/Pact/Core/IR/Eval/CEK.hs index ab04d4741..eae96f83f 100644 --- a/pact-core/Pact/Core/IR/Eval/CEK.hs +++ b/pact-core/Pact/Core/IR/Eval/CEK.hs @@ -40,6 +40,7 @@ import Data.List.NonEmpty(NonEmpty(..)) import Data.Foldable(find, foldl') import qualified Data.RAList as RAList import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Vector as V import qualified Data.Set as S import qualified Data.Map.Strict as M @@ -58,6 +59,7 @@ import Pact.Core.ModRefs import Pact.Core.Environment import Pact.Core.Persistence import Pact.Core.Hash +import Pact.Core.StableEncoding import Pact.Core.IR.Term hiding (PactStep) import Pact.Core.IR.Eval.Runtime @@ -255,9 +257,12 @@ initPact i pc cont handler cenv = do applyPact i pc pStep cont handler cenv' mempty Just ps -> let - npId = mkNestedPactId pc (_psPactId ps) + PactId p = _psPactId ps + npId = hashToPactId (pactHash (T.encodeUtf8 p <> ":" <> encodeStable pc)) pStep = PactStep (_psStep ps) (_psRollback ps) npId Nothing in applyNestedPact i pc pStep cont handler cenv + where + hashToPactId = PactId . hashToText applyPact :: MonadEval b i m diff --git a/pact-core/Pact/Core/Pacts/Types.hs b/pact-core/Pact/Core/Pacts/Types.hs index b64221904..7962f44c7 100644 --- a/pact-core/Pact/Core/Pacts/Types.hs +++ b/pact-core/Pact/Core/Pacts/Types.hs @@ -12,8 +12,6 @@ module Pact.Core.Pacts.Types , peStepCount, peYield, peStep, peContinuation, peStepHasRollback, pePactId , peNestedPactExec , Yield(..) - , hashToPactId - , mkNestedPactId , Provenance(..) ) where @@ -21,9 +19,6 @@ module Pact.Core.Pacts.Types import Data.Text(Text) import Control.Lens import Data.Map.Strict (Map) -import qualified Data.Text.Encoding as T -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 import Pact.Core.PactValue import Pact.Core.Names @@ -35,9 +30,6 @@ newtype PactId = PactId Text deriving (Eq,Ord,Show,Pretty) -hashToPactId :: Hash -> PactId -hashToPactId = PactId . hashToText - data PactContinuation name v = PactContinuation { _pcName :: name @@ -56,14 +48,6 @@ data Provenance = Provenance -- ^ a hash of current containing module } deriving (Eq, Show) -encodePactContinuation :: PactContinuation FullyQualifiedName PactValue -> ByteString -encodePactContinuation = BS8.pack . show - -mkNestedPactId :: PactContinuation FullyQualifiedName PactValue -> PactId -> PactId -mkNestedPactId pc (PactId parent) = - hashToPactId (pactHash (T.encodeUtf8 parent <> ":" <> encodePactContinuation pc)) -- TODO add pc - - -- | `Yield` representing an object data Yield @@ -95,4 +79,3 @@ data PactStep = PactStep } deriving Show makeLenses ''PactStep - diff --git a/pact-core/Pact/Core/StableEncoding.hs b/pact-core/Pact/Core/StableEncoding.hs index 0cfaf912d..e670a4381 100644 --- a/pact-core/Pact/Core/StableEncoding.hs +++ b/pact-core/Pact/Core/StableEncoding.hs @@ -1,74 +1,189 @@ --- | +{-# LANGUAGE TypeApplications #-} + +-- | +-- +-- Stable encoding which matches Pacts StableEncoding. +-- module Pact.Core.StableEncoding + (encodeStable) where import Pact.Core.PactValue - -newtype StableEncoding a - = StableEncoding a - - +import Pact.Core.Literal +import Pact.Core.Guards +import Pact.Core.Names +import Pact.Core.ModRefs +import Pact.Core.Hash +import Pact.Core.Pacts.Types +import Pact.Time + +import Data.Decimal (DecimalRaw(..)) + +import qualified Data.Text as T +import Data.Scientific (Scientific) +import qualified Pact.JSON.Encode as J +import qualified Data.Set as Set +import Data.Map.Strict (Map) +import Pact.JSON.Legacy.Utils +import Data.Ratio ((%), denominator) +import Data.ByteString (ByteString) + +encodeStable :: J.Encode (StableEncoding a) => a -> ByteString +encodeStable = J.encodeStrict . StableEncoding + +newtype StableEncoding a = StableEncoding a + deriving (Ord, Eq) + + +-- | Stable encoding of `Literal` +-- +-- `isSafeInteger` checks for the Javascript maximum/minimum numbers. +-- Details can be found here: https://github.com/kadena-io/pact/blob/e72d86749f5d65ac8d6e07a7652dd2ffb468607b/src/Pact/Types/Codec.hs#L44 instance J.Encode (StableEncoding Literal) where build (StableEncoding lit) = case lit of - LString t -> undefined - LInteger i -> undefined - LDecimal d -> undefined - LUnit -> undefined - LBool b -> undefined + LString t -> J.build t + LInteger i -> encodeInteger i + LDecimal d -> encodeDecimal d + LUnit -> encodeUnit + LBool b -> J.build b + where + encodeInteger i + | isSafeInteger i = J.object [ "int" J..= J.Aeson i ] + | otherwise = J.object [ "int" J..= T.pack (show i) ] + encodeDecimal d@(Decimal _ mantissa) + | isSafeInteger mantissa = J.build $ J.Aeson @Scientific $ fromRational $ toRational d + | otherwise = J.object [ "decimal" J..= T.pack (show d) ] + encodeUnit = J.object ["unit" J..= T.empty] -- TODO: Discuss? + isSafeInteger i = i >= -9007199254740991 && i <= 9007199254740991 {-# INLINABLE build #-} + +-- | Stable encoding of `Guard FullyQualifiedName PactValue` instance J.Encode (StableEncoding (Guard FullyQualifiedName PactValue)) where build (StableEncoding g) = case g of - GKetset ks -> undefined - GKetSetRef ksn -> undefined - GUserGuard -> undefined - GCapabilityGuard cg -> undefined - GModuleGuard mg -> undefined + GKeyset ks -> J.build (StableEncoding ks) + GKeySetRef ksn -> J.object ["keysetref" J..= StableEncoding ksn] + GUserGuard ug -> J.build (StableEncoding ug) + GCapabilityGuard cg -> J.build (StableEncoding cg) + GModuleGuard mg -> J.build (StableEncoding mg) {-# INLINABLE build #-} +-- | Stable encoding of `CapabilityGuard FullyQualifiedName PactValue` instance J.Encode (StableEncoding (CapabilityGuard FullyQualifiedName PactValue)) where - build (StableEncoding (CapabilityGuard name args)) = undefined + build (StableEncoding (CapabilityGuard name args)) = J.object + [ "cgPactId" J..= (error "a" :: T.Text) -- TODO: Check availability + , "cgArgs" J..= J.Array (StableEncoding <$> args) + , "cgName" J..= StableEncoding name + ] {-# INLINABLE build #-} -instance J.Encode (StableEncoding ModuleGuards) where - build (StableEncoding (ModuleGuard mod name)) = undefined +-- | Stable encoding of `FullyQualifiedName` +instance J.Encode (StableEncoding FullyQualifiedName) where + build (StableEncoding (FullyQualifiedName (ModuleName mn mns) n (ModuleHash mh))) = J.build t + where + t = maybe "" ((<> ".") . _namespaceName) mns <> mn <> "." <> n <> ".{" <> hashToText mh <> "}" {-# INLINABLE build #-} +-- | Stable encoding of `ModuleGuard` +instance J.Encode (StableEncoding ModuleGuard) where + build (StableEncoding (ModuleGuard m name)) = J.object + [ "moduleName" J..= _mnName m + , "name" J..= name + ] + {-# INLINABLE build #-} + +-- | Stable encoding of `UserGuard FullyQualifiedName PactValue` instance J.Encode (StableEncoding (UserGuard FullyQualifiedName PactValue)) where - build (StableEncoding (UserGuard fun args)) = undefined + build (StableEncoding (UserGuard fun args)) = J.object + [ "args" J..= J.array (StableEncoding <$> args) + , "fun" J..= StableEncoding fun + ] {-# INLINABLE build #-} +-- TODO: KeySetName is namespaced (maybe) +-- | Stable encoding of `KeySetName` instance J.Encode (StableEncoding KeySetName) where - build (StableEncoding (KeySetName ksn)) = undefined + build (StableEncoding (KeySetName ksn)) = J.build ksn {-# INLINABLE build #-} +-- | Stable encoding of `KeySet FullyQualifiedName` instance J.Encode (StableEncoding (KeySet FullyQualifiedName)) where - build (StableEncoding (KeySet keys predFun)) = undefined + build (StableEncoding (KeySet keys predFun)) =J.object + [ "pred" J..= StableEncoding predFun + , "keys" J..= J.Array (Set.map StableEncoding keys) -- TODO: is this valid? + ] + {-# INLINABLE build #-} + +-- | Stable encoding of `Map Field PactValue` +instance J.Encode (StableEncoding (Map Field PactValue)) where + build (StableEncoding o) = J.build (legacyMap _field (StableEncoding <$> o)) {-# INLINABLE build #-} +-- | Stable encoding of `KSPredicate FullyQualifiedName` instance J.Encode (StableEncoding (KSPredicate FullyQualifiedName)) where build (StableEncoding ksp) = case ksp of - KeysAll -> undefined - Keys2 -> undefined - KeysAny -> undefined + KeysAll -> J.build ("keys-all" :: T.Text) + Keys2 -> J.build ("keys-2" :: T.Text) + KeysAny -> J.build ("keys-any" :: T.Text) {-# INLINABLE build #-} +-- | Stable encoding of `PublicKeyText` +instance J.Encode (StableEncoding PublicKeyText) where + build (StableEncoding (PublicKeyText pkt)) = J.build pkt + {-# INLINABLE build #-} +-- | Stable encoding of `NamespaceName` +instance J.Encode (StableEncoding NamespaceName) where + build (StableEncoding (NamespaceName ns)) = J.build ns + {-# INLINABLE build #-} -instance J.Encode (StableEncoding PublicKeyText) where - build (StableEncoding (PublicKeyText pkt)) = undefined +-- | Stable encoding of `ModuleName` +instance J.Encode (StableEncoding ModuleName) where + build (StableEncoding (ModuleName mn ns)) = J.object + [ "namespace" J..= (StableEncoding <$> ns) + , "name" J..= mn + ] {-# INLINABLE build #-} +-- | Stable encoding of `ModRef` +instance J.Encode (StableEncoding ModRef) where + build (StableEncoding (ModRef mn imp _ref)) = J.object + [ "refSpec" J..= J.Array (StableEncoding <$> imp) +-- , "refInfo" J..= _modRefInfo o + , "refName" J..= StableEncoding mn + ] + {-# INLINABLE build #-} +-- | Stable encoding of `UTCTime` +-- +-- See https://github.com/kadena-io/pact/blob/e72d86749f5d65ac8d6e07a7652dd2ffb468607b/src/Pact/Types/Codec.hs#L150 +-- for further details +instance J.Encode (StableEncoding UTCTime) where + build (StableEncoding utc) + | denom utc == 1 = J.object [ "time" J..= T.pack (formatTime "%Y-%m-%dT%H:%M:%SZ" utc) ] + | otherwise = J.object [ "timep" J..= T.pack (formatTime "%Y-%m-%dT%H:%M:%S.%vZ" utc) ] + where + denom :: UTCTime -> Integer + denom = denominator . (% 1000) . fromIntegral . toPosixTimestampMicros + {-# INLINABLE build #-} +-- | Stable encoding of `PactValue` instance J.Encode (StableEncoding PactValue) where build (StableEncoding pv) = case pv of - PLiteral lit J.build (StableEncoding lit) - PList l -> J.build (J.Array (StableEncoding <$> v)) - PGuard g -> undefined - PObject o -> undefined - PModRef mr -> undefined - PCapToken ct -> undefined - PTime pt -> undefined + PLiteral lit -> J.build (StableEncoding lit) + PList l -> J.build (J.Array (StableEncoding <$> l)) + PGuard g -> J.build (StableEncoding g) + PObject o -> J.build (StableEncoding o) + PModRef mr -> J.build (StableEncoding mr) + PCapToken _ct -> error "not implemented" + PTime pt -> J.build (StableEncoding pt) + {-# INLINABLE build #-} + +-- | Stable encoding of `PactContinuation FullyQualifiedName PactValue` +instance J.Encode (StableEncoding (PactContinuation FullyQualifiedName PactValue)) where + build (StableEncoding (PactContinuation name args))= J.object + [ "args" J..= J.Array (StableEncoding <$> args) + , "def" J..= J.build (StableEncoding name) + ] {-# INLINABLE build #-} From 420a0bd86a50453d73f5106fdfc9b3226586237b Mon Sep 17 00:00:00 2001 From: jmcardon Date: Thu, 19 Oct 2023 10:50:06 -0400 Subject: [PATCH 3/6] commit robert's suggestion --- pact-core/Pact/Core/Repl/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pact-core/Pact/Core/Repl/Utils.hs b/pact-core/Pact/Core/Repl/Utils.hs index 2f967193b..f92e824fd 100644 --- a/pact-core/Pact/Core/Repl/Utils.hs +++ b/pact-core/Pact/Core/Repl/Utils.hs @@ -284,7 +284,7 @@ replError (ReplSource file src) pe = spanLen = _liEndLine pei - _liStartLine pei -- We want the padding to be the biggest line number we will show, which -- is endLine + 1 - maxPad = T.length (T.pack (show ((_liEndLine pei + 1)))) + 1 + maxPad = length (show (_liEndLine pei + 1)) + 1 slice = withLine start maxPad $ take (max 1 spanLen) $ drop start srcLines -- Render ^^^ only in the column slice colMarker = T.replicate (maxPad+1) " " <> "| " <> T.replicate (_liStartColumn pei) " " <> T.replicate (max 1 (_liEndColumn pei - _liStartColumn pei)) "^" From e72fd8f1a9405364c8ebceb285c82db2c48878f0 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Thu, 19 Oct 2023 11:02:43 -0400 Subject: [PATCH 4/6] move pactid --- pact-core/Pact/Core/Capabilities.hs | 20 -------------------- pact-core/Pact/Core/Guards.hs | 6 ++++-- pact-core/Pact/Core/Names.hs | 12 ++++++++++++ pact-core/Pact/Core/Pacts/Types.hs | 8 +------- 4 files changed, 17 insertions(+), 29 deletions(-) diff --git a/pact-core/Pact/Core/Capabilities.hs b/pact-core/Pact/Core/Capabilities.hs index 200e86dc8..5c0a8e021 100644 --- a/pact-core/Pact/Core/Capabilities.hs +++ b/pact-core/Pact/Core/Capabilities.hs @@ -34,8 +34,6 @@ import Pact.Core.Hash data DefManagedMeta name = DefManagedMeta Int (FQNameRef name) | AutoManagedMeta - -- { _dmManagedArgIx :: Int - -- , _dmManagerFn :: FQNameRef name deriving (Show) data DefCapMeta name @@ -46,38 +44,20 @@ data DefCapMeta name data CapForm name e = WithCapability name [e] e - -- | RequireCapability name [e] - -- | ComposeCapability name [e] - -- | InstallCapability name [e] - -- | EmitEvent name [e] | CreateUserGuard name [e] deriving (Show, Functor, Foldable, Traversable) capFormName :: Lens (CapForm name e) (CapForm name' e) name name' capFormName f = \case WithCapability name es e -> (\fq -> WithCapability fq es e) <$> f name - -- RequireCapability name es -> (`RequireCapability` es) <$> f name - -- ComposeCapability name es -> (`ComposeCapability` es) <$> f name - -- InstallCapability name es -> (`InstallCapability` es) <$> f name - -- EmitEvent name es -> (`EmitEvent` es) <$> f name CreateUserGuard name es -> (`CreateUserGuard` es) <$> f name instance (Pretty name, Pretty e) => Pretty (CapForm name e) where pretty = \case WithCapability name es e -> parens ("with-capability" <+> parens (pretty name <+> hsep (pretty <$> es)) <+> pretty e) - -- RequireCapability name es -> - -- parens ("require-capability" <+> parens (pretty name <+> hsep (pretty <$> es))) - -- ComposeCapability name es -> - -- parens ("compose-capability" <+> parens (pretty name <+> hsep (pretty <$> es))) - -- InstallCapability name es -> - -- parens ("install-capability" <+> parens (pretty name <+> hsep (pretty <$> es))) - -- EmitEvent name es -> - -- parens ("emit-event" <+> parens (pretty name <+> hsep (pretty <$> es))) CreateUserGuard name es -> parens ("create-user-guard" <+> parens (pretty name <+> hsep (pretty <$> es))) - -- CreateModuleGuard mn -> - -- parens ("create-module-guard" <+> pretty mn) -- | An acquired capability token -- with the reference diff --git a/pact-core/Pact/Core/Guards.hs b/pact-core/Pact/Core/Guards.hs index bf1bd5716..63c3389f2 100644 --- a/pact-core/Pact/Core/Guards.hs +++ b/pact-core/Pact/Core/Guards.hs @@ -94,6 +94,8 @@ data ModuleGuard , _mgName :: Text } deriving (Show, Eq, Ord) +-- Todo: module guards are compared on equality based on name +-- Why???? -- instance Eq ModuleGuard where -- mg == mg' = _mgModule mg == _mgModule mg' @@ -109,8 +111,8 @@ instance Pretty ModuleGuard where data CapabilityGuard name term = CapabilityGuard { _cgName :: !name - , _cgArgs :: ![term] } - -- , _cgPactId :: !(Maybe PactId) + , _cgArgs :: ![term] + , _cgPactId :: !(Maybe PactId) } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) data Guard name term diff --git a/pact-core/Pact/Core/Names.hs b/pact-core/Pact/Core/Names.hs index 4d8be0699..26eea46d2 100644 --- a/pact-core/Pact/Core/Names.hs +++ b/pact-core/Pact/Core/Names.hs @@ -56,6 +56,7 @@ module Pact.Core.Names , fqModule , fqHash , userTable + , PactId(..) ) where import Control.Lens @@ -335,3 +336,14 @@ makeLenses ''FullyQualifiedName userTable :: TableName -> TableName userTable (TableName tn) = TableName ("USER_" <> tn) + +-- | The identifier that indexes defpacts in the db, +-- generally computed from the continuation, or +-- in the case of nested defpacts, the hash of the +-- parent + the nested continuation +newtype PactId + = PactId Text + deriving (Eq,Ord,Show) + +instance Pretty PactId where + pretty (PactId p) = pretty p diff --git a/pact-core/Pact/Core/Pacts/Types.hs b/pact-core/Pact/Core/Pacts/Types.hs index 7962f44c7..218647243 100644 --- a/pact-core/Pact/Core/Pacts/Types.hs +++ b/pact-core/Pact/Core/Pacts/Types.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module Pact.Core.Pacts.Types - ( PactId(..) - , PactContinuation(..) + ( PactContinuation(..) , pcName, pcArgs , PactStep(..) , psStep, psRollback, psPactId, psResume @@ -26,10 +24,6 @@ import Pact.Core.Hash import Pact.Core.Pretty import Pact.Core.ChainData -newtype PactId - = PactId Text - deriving (Eq,Ord,Show,Pretty) - data PactContinuation name v = PactContinuation { _pcName :: name From c43697ccc6ea82a12623f22440eb4b896068a002 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Thu, 19 Oct 2023 13:48:53 -0400 Subject: [PATCH 5/6] fix resume pact arg issue --- pact-core-tests/pact-tests/caps.repl | 52 ++++++++--------- pact-core/Pact/Core/Builtin.hs | 3 + pact-core/Pact/Core/Errors.hs | 60 ++++++++++---------- pact-core/Pact/Core/Guards.hs | 5 +- pact-core/Pact/Core/IR/Desugar.hs | 17 +++--- pact-core/Pact/Core/IR/Eval/CEK.hs | 3 +- pact-core/Pact/Core/IR/Eval/RawBuiltin.hs | 51 ++++++++++------- pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs | 8 +++ pact-core/Pact/Core/Names.hs | 1 - pact-core/Pact/Core/Pacts/Types.hs | 2 - pact-core/Pact/Core/StableEncoding.hs | 9 ++- pact-core/Pact/Core/Syntax/Parser.y | 2 +- 12 files changed, 119 insertions(+), 94 deletions(-) diff --git a/pact-core-tests/pact-tests/caps.repl b/pact-core-tests/pact-tests/caps.repl index 709f4021c..50092a3e7 100644 --- a/pact-core-tests/pact-tests/caps.repl +++ b/pact-core-tests/pact-tests/caps.repl @@ -798,12 +798,12 @@ (defun test-cap-guard (n:string m:string) (with-capability (CAP1 n) (enforce-guard (create-capability-guard (CAP1 m))))) - ; (defpact cg-pact (kw:string kr:string n:string m:string) - ; (step (write cg-tbl kw { 'g: (create-capability-pact-guard (CAP1 m)) })) - ; (step - ; (with-read cg-tbl kr { 'g := cg } - ; (with-capability (CAP1 n) (enforce-guard cg)))) - ; ) + (defpact cg-pact (kw:string kr:string n:string m:string) + (step (write cg-tbl kw { 'g: (create-capability-pact-guard (CAP1 m)) })) + (step + (with-read cg-tbl kr { 'g := cg } + (with-capability (CAP1 n) (enforce-guard cg)))) + ) ) (create-table cg-tbl) @@ -817,31 +817,31 @@ "Capability not acquired" (test-cap-guard "A" "B")) -; (env-hash (hash 1)) +(env-hash (hash 1)) -; (cg-pact 'k1 'k1 "C" "C") -; (expect -; "cap pact guard succeeds" -; true -; (continue-pact 1)) +(cg-pact 'k1 'k1 "C" "C") +(expect + "cap pact guard succeeds" + true + (continue-pact 1)) -; (pact-state true) -; (env-hash (hash 2)) +(pact-state true) +(env-hash (hash 2)) -; (cg-pact 'k2 'k2 "D" "E") -; (expect-failure -; "cap pact guard fails on wrong cap" -; "Capability not acquired" -; (continue-pact 1)) +(cg-pact 'k2 'k2 "D" "E") +(expect-failure + "cap pact guard fails on wrong cap" + "Capability not acquired" + (continue-pact 1)) -; (pact-state true) -; (env-hash (hash 3)) +(pact-state true) +(env-hash (hash 3)) -; (cg-pact 'k3 'k1 "C" "C") -; (expect-failure -; "cap pact guard fails on wrong pact id" -; "Invalid Pact ID" -; (continue-pact 1)) +(cg-pact 'k3 'k1 "C" "C") +(expect-failure + "cap pact guard fails on wrong pact id" + "Invalid Pact ID" + (continue-pact 1)) (commit-tx) (begin-tx) diff --git a/pact-core/Pact/Core/Builtin.hs b/pact-core/Pact/Core/Builtin.hs index 5a3052e47..e713184b6 100644 --- a/pact-core/Pact/Core/Builtin.hs +++ b/pact-core/Pact/Core/Builtin.hs @@ -237,6 +237,7 @@ data RawBuiltin | RawInstallCapability | RawEmitEvent | RawCreateCapabilityGuard + | RawCreateCapabilityPactGuard | RawCreateModuleGuard -- Database functions | RawCreateTable @@ -356,6 +357,7 @@ rawBuiltinToText = \case RawEnforceKeyset -> "enforce-keyset" RawKeysetRefGuard -> "keyset-ref-guard" RawCreateCapabilityGuard -> "create-capability-guard" + RawCreateCapabilityPactGuard -> "create-capability-pact-guard" RawCreateModuleGuard -> "create-module-guard" RawAt -> "at" RawMakeList -> "make-list" @@ -481,6 +483,7 @@ instance IsBuiltin RawBuiltin where RawEnforceGuard -> 1 RawKeysetRefGuard -> 1 RawCreateCapabilityGuard -> 1 + RawCreateCapabilityPactGuard -> 1 RawCreateModuleGuard -> 1 RawAt -> 2 RawMakeList -> 2 diff --git a/pact-core/Pact/Core/Errors.hs b/pact-core/Pact/Core/Errors.hs index 1b2149e85..cf90cd39b 100644 --- a/pact-core/Pact/Core/Errors.hs +++ b/pact-core/Pact/Core/Errors.hs @@ -212,6 +212,8 @@ instance Pretty DesugarError where Pretty.hsep ["Expected free variable in expression, found locally bound: ", pretty t] e -> pretty (show e) +-- | Argument type mismatch meant for errors +-- that does not force you to show the whole PactValue data ArgTypeError = ATEPrim PrimType | ATEList @@ -329,8 +331,10 @@ data EvalError | InvalidEventCap FullyQualifiedName | NestedDefpactsNotAdvanced PactId | ExpectedPactValue + | NotInPactExecution deriving Show + instance Pretty EvalError where pretty :: EvalError -> Pretty.Doc ann pretty = \case @@ -359,14 +363,14 @@ instance Pretty EvalError where Pretty.hsep ["Native evaluation error for native", pretty n <> ",", "received incorrect argument(s) of type(s)", Pretty.commaSep tys] EvalError txt -> Pretty.hsep ["Program encountered an unhandled raised error:", pretty txt] - ModRefNotRefined _ -> error "" - InvalidDefKind _ _ -> error "" - NoSuchDef _ -> error "" - InvalidManagedCap _ -> error "" - CapNotInstalled _ -> error "" - NameNotInScope _ -> error "" - DefIsNotClosure _ -> error "" - NoSuchKeySet _ -> error "" + -- ModRefNotRefined _ -> error "" + -- InvalidDefKind _ _ -> error "" + -- NoSuchDef _ -> error "" + -- InvalidManagedCap _ -> error "" + -- CapNotInstalled _ -> error "" + -- NameNotInScope _ -> error "" + -- DefIsNotClosure _ -> error "" + -- NoSuchKeySet _ -> error "" YieldOutsiteDefPact -> "Try to yield a value outside a running DefPact execution" NoActivePactExec -> @@ -433,22 +437,24 @@ instance Pretty EvalError where , "step: " <> pretty (_psStep ps) , "PactExec step: " <> pretty (_peStep pe + 1) ] - CannotUpgradeInterface _ -> error "" - ModuleGovernanceFailure _ -> error "" - DbOpFailure _ -> error "" - DynNameIsNotModRef _ -> error "" - ModuleDoesNotExist _ -> error "" - ExpectedModule _ -> error "" - HashNotBlessed _ _ -> error "" - CannotApplyPartialClosure -> error "" - ClosureAppliedToTooManyArgs -> error "" - FormIllegalWithinDefcap _ -> error "" - RunTimeTypecheckFailure _ _ -> error "" - NativeIsTopLevelOnly _ -> error "" - EventDoesNotMatchModule _ -> error "" - InvalidEventCap _ -> error "" - NestedDefpactsNotAdvanced _ -> error "" - ExpectedPactValue -> error "" + e -> pretty (show e) + -- CannotUpgradeInterface _ -> error "" + -- ModuleGovernanceFailure _ -> error "" + -- DbOpFailure _ -> error "" + -- DynNameIsNotModRef _ -> error "" + -- ModuleDoesNotExist _ -> error "" + -- ExpectedModule _ -> error "" + -- HashNotBlessed _ _ -> error "" + -- CannotApplyPartialClosure -> error "" + -- ClosureAppliedToTooManyArgs -> error "" + -- FormIllegalWithinDefcap _ -> error "" + -- RunTimeTypecheckFailure _ _ -> error "" + -- NativeIsTopLevelOnly _ -> error "" + -- EventDoesNotMatchModule _ -> error "" + -- InvalidEventCap _ -> error "" + -- NestedDefpactsNotAdvanced _ -> error "" + -- ExpectedPactValue -> error "" + -- NotInPactExecution -> error "" instance Exception EvalError @@ -476,14 +482,8 @@ peInfo f = \case PEParseError pe <$> f info PEDesugarError de info -> PEDesugarError de <$> f info - -- PETypecheckError pe info -> - -- PETypecheckError pe <$> f info - -- PEOverloadError oe info -> - -- PEOverloadError oe <$> f info PEExecutionError ee info -> PEExecutionError ee <$> f info - -- PEFatalError fpe info -> - -- PEFatalError fpe <$> f info instance (Show info, Typeable info) => Exception (PactError info) diff --git a/pact-core/Pact/Core/Guards.hs b/pact-core/Pact/Core/Guards.hs index 63c3389f2..28b3601ef 100644 --- a/pact-core/Pact/Core/Guards.hs +++ b/pact-core/Pact/Core/Guards.hs @@ -140,9 +140,8 @@ data Namespace name term } deriving (Eq, Show) instance (Pretty name, Pretty term) => Pretty (CapabilityGuard name term) where - pretty (CapabilityGuard cg args) = "CapabilityGuard" <+> commaBraces + pretty (CapabilityGuard cg args pid) = "CapabilityGuard" <+> commaBraces [ "name: " <> pretty cg , "args: " <> pretty args - -- todo: pactId when I merge defpcats - -- , "pactId: " <> pretty _cgPactId + , "pactId: " <> pretty pid ] diff --git a/pact-core/Pact/Core/IR/Desugar.hs b/pact-core/Pact/Core/IR/Desugar.hs index 6b66d86e7..51b5b84ba 100644 --- a/pact-core/Pact/Core/IR/Desugar.hs +++ b/pact-core/Pact/Core/IR/Desugar.hs @@ -145,6 +145,7 @@ type MonadDesugar raw reso i m = , MonadError (PactError i) m , MonadState (RenamerState reso i) m , MonadReader (RenamerEnv reso i) m + , Show raw , Show reso , Show i , MonadIO m) @@ -243,6 +244,8 @@ instance DesugarBuiltin (ReplBuiltin RawBuiltin) where App (Builtin (RBuiltinRepl RExpectFailureMatch) i) [e1, e2, suspendTerm e3] i desugarAppArity i (RBuiltinRepl RContinuePact) [e1, e2] | isn't _Lam e2 = App (Builtin (RBuiltinRepl RContinuePactRollback) i) [e1, e2] i + desugarAppArity i (RBuiltinRepl RPactState) [e1] = + App (Builtin (RBuiltinRepl RResetPactState) i) [e1] i desugarAppArity i (RBuiltinRepl RContinuePact) [e1, e2, e3] | isn't _Lam e2 && isn't _Lam e3 = App (Builtin (RBuiltinRepl RContinuePactRollbackYield) i) [e1, e2, e3] i @@ -1462,7 +1465,7 @@ runDesugar' pdb loaded act = do pure (DesugarOutput renamed loaded' deps) runDesugarTerm - :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i) + :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw) => Proxy raw -> PactDb reso i -> Loaded reso i @@ -1471,7 +1474,7 @@ runDesugarTerm runDesugarTerm _ pdb loaded = runDesugar' pdb loaded . RenamerT . (desugarLispTerm >=> renameTerm) runDesugarModule' - :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i) + :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw) => Proxy raw -> PactDb reso i -> Loaded reso i @@ -1480,7 +1483,7 @@ runDesugarModule' runDesugarModule' _ pdb loaded = runDesugar' pdb loaded . RenamerT . (desugarModule >=> renameModule) runDesugarInterface - :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i) + :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw) => Proxy raw -> PactDb reso i -> Loaded reso i @@ -1489,7 +1492,7 @@ runDesugarInterface runDesugarInterface _ pdb loaded = runDesugar' pdb loaded . RenamerT . (desugarInterface >=> renameInterface) runDesugarReplDefun - :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i) + :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw) => Proxy raw -> PactDb reso i -> Loaded reso i @@ -1502,7 +1505,7 @@ runDesugarReplDefun _ pdb loaded = . (desugarDefun >=> renameReplDefun) runDesugarReplDefConst - :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i) + :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw) => Proxy raw -> PactDb reso i -> Loaded reso i @@ -1515,7 +1518,7 @@ runDesugarReplDefConst _ pdb loaded = . (desugarDefConst >=> renameReplDefConst) runDesugarTopLevel - :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i) + :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw) => Proxy raw -> PactDb reso i -> Loaded reso i @@ -1530,7 +1533,7 @@ runDesugarTopLevel proxy pdb loaded = \case runDesugarReplTopLevel - :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i) + :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw) => Proxy raw -> PactDb reso i -> Loaded reso i diff --git a/pact-core/Pact/Core/IR/Eval/CEK.hs b/pact-core/Pact/Core/IR/Eval/CEK.hs index eae96f83f..4f7c320fa 100644 --- a/pact-core/Pact/Core/IR/Eval/CEK.hs +++ b/pact-core/Pact/Core/IR/Eval/CEK.hs @@ -424,10 +424,11 @@ resumePact i cont handler env crossChainContinuation = viewCEKEnv eePactStep >>= throwExecutionError i (DefPactStepMissmatch ps pe) let pc = view peContinuation pe + args = VPactValue <$> _pcArgs pc resume = case _psResume ps of r@Just{} -> r Nothing -> _peYield pe - env' = set cePactStep (Just $ set psResume resume ps) env + env' = set ceLocal (RAList.fromList (reverse args)) $ set cePactStep (Just $ set psResume resume ps) env applyPact i pc ps cont handler env' (_peNestedPactExec pe) diff --git a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs index e8df70c38..2a6b7153b 100644 --- a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs +++ b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs @@ -57,6 +57,7 @@ import Pact.Core.Capabilities import Pact.Core.IR.Term import Pact.Core.IR.Eval.Runtime +import Pact.Core.StableEncoding import Pact.Core.IR.Eval.CEK import qualified Pact.Core.Pretty as Pretty @@ -522,13 +523,6 @@ coreEnumerateStepN = \info b cont handler _env -> \case returnCEKValue cont handler (VList (PLiteral . LInteger <$> v)) args -> argsError info b args --- concatList :: (IsBuiltin b, MonadEval b i m) => b -> NativeFn b i m --- concatList = \info b cont handler env -> \case --- [VList li] -> do --- li' <- traverse asList li --- returnCEKValue cont handler (VList (V.concat (V.toList li'))) --- _ -> failInvariant "takeList" - makeList :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m makeList = \info b cont handler _env -> \case [VLiteral (LInteger i), VPactValue v] -> do @@ -737,16 +731,20 @@ enforceCapGuard -> CEKErrorHandler b i m -> CapabilityGuard FullyQualifiedName PactValue -> m (EvalResult b i m) -enforceCapGuard info cont handler (CapabilityGuard fqn args) = do - -- let ct = CapToken (fqnToQualName fqn) args - cond <- isCapInStack (CapToken fqn args) - -- caps <- useEvalState (esCaps.csSlots) - -- let csToSet cs = S.insert (_csCap cs) (S.fromList (_csComposed cs)) - -- capSet = foldMap csToSet caps - if cond then returnCEKValue cont handler (VBool True) - else do - let errMsg = "Capability guard enforce failure cap not in scope: " <> renderFullyQualName fqn - returnCEK cont handler (VError errMsg info) +enforceCapGuard info cont handler (CapabilityGuard fqn args mpid) = do + case mpid of + Nothing -> enforceCap + Just pid -> do + currPid <- getPactId info + if currPid == pid then enforceCap + else returnCEK cont handler (VError "Capability pact guard failed: invalid pact id" info) + where + enforceCap = do + cond <- isCapInStack (CapToken fqn args) + if cond then returnCEKValue cont handler (VBool True) + else do + let errMsg = "Capability guard enforce failure cap not in scope: " <> renderFullyQualName fqn + returnCEK cont handler (VError errMsg info) runUserGuard :: MonadEval b i m @@ -1088,10 +1086,18 @@ coreEmitEvent = \info b cont handler env -> \case createCapGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m createCapGuard = \info b cont handler _env -> \case [VCapToken ct] -> - let cg = CapabilityGuard (_ctName ct) (_ctArgs ct) + let cg = CapabilityGuard (_ctName ct) (_ctArgs ct) Nothing in returnCEKValue cont handler (VGuard (GCapabilityGuard cg)) args -> argsError info b args +createCapabilityPactGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +createCapabilityPactGuard = \info b cont handler _env -> \case + [VCapToken ct] -> do + pid <- getPactId info + let cg = CapabilityGuard (_ctName ct) (_ctArgs ct) (Just pid) + returnCEKValue cont handler (VGuard (GCapabilityGuard cg)) + args -> argsError info b args + createModuleGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m createModuleGuard = \info b cont handler _env -> \case [VString n] -> @@ -1268,9 +1274,13 @@ coreWhere = \info b cont handler _env -> \case coreHash :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m coreHash = \info b cont handler _env -> \case - [VString s] -> do - returnCEKValue cont handler $ VString $ hashToText $ pactHash $ T.encodeUtf8 s + [VString s] -> + returnCEKValue cont handler (go (T.encodeUtf8 s)) + [VPactValue pv] -> + returnCEKValue cont handler (go (encodeStable pv)) args -> argsError info b args + where + go = VString . hashToText . pactHash txHash :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m txHash = \info b cont handler _env -> \case @@ -1489,6 +1499,7 @@ rawBuiltinRuntime = \case RawComposeCapability -> composeCapability RawInstallCapability -> installCapability RawCreateCapabilityGuard -> createCapGuard + RawCreateCapabilityPactGuard -> createCapabilityPactGuard RawCreateModuleGuard -> createModuleGuard RawEmitEvent -> coreEmitEvent RawCreateTable -> createTable diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs index aae3cf51d..461fca24a 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs @@ -40,6 +40,7 @@ module Pact.Core.IR.Eval.Runtime.Utils , evalStateToErrorState , restoreFromErrorState , (.==) + , getPactId ) where import Control.Lens hiding ((%%=)) @@ -68,6 +69,7 @@ import Pact.Core.Capabilities import Pact.Core.Persistence import Pact.Core.Hash import Pact.Core.Environment +import Pact.Core.Pacts.Types mkBuiltinFn :: (IsBuiltin b) @@ -366,3 +368,9 @@ sysOnlyEnv e DModules -> _pdbRead pdb dom k DPacts -> _pdbRead pdb dom k +getPactId :: (MonadEval b i m) => i -> m PactId +getPactId info = + useEvalState esPactExec >>= \case + Just pe -> pure (_pePactId pe) + Nothing -> + throwExecutionError info NotInPactExecution diff --git a/pact-core/Pact/Core/Names.hs b/pact-core/Pact/Core/Names.hs index 26eea46d2..8355eec46 100644 --- a/pact-core/Pact/Core/Names.hs +++ b/pact-core/Pact/Core/Names.hs @@ -45,7 +45,6 @@ module Pact.Core.Names , replRawModuleName , replModuleName , replModuleHash --- , DefKind(..) , fqnToName , fqnToQualName , NativeName(..) diff --git a/pact-core/Pact/Core/Pacts/Types.hs b/pact-core/Pact/Core/Pacts/Types.hs index 218647243..d37b9531a 100644 --- a/pact-core/Pact/Core/Pacts/Types.hs +++ b/pact-core/Pact/Core/Pacts/Types.hs @@ -14,14 +14,12 @@ module Pact.Core.Pacts.Types ) where -- Todo: yield -import Data.Text(Text) import Control.Lens import Data.Map.Strict (Map) import Pact.Core.PactValue import Pact.Core.Names import Pact.Core.Hash -import Pact.Core.Pretty import Pact.Core.ChainData data PactContinuation name v diff --git a/pact-core/Pact/Core/StableEncoding.hs b/pact-core/Pact/Core/StableEncoding.hs index e670a4381..06332e6ed 100644 --- a/pact-core/Pact/Core/StableEncoding.hs +++ b/pact-core/Pact/Core/StableEncoding.hs @@ -35,6 +35,9 @@ encodeStable = J.encodeStrict . StableEncoding newtype StableEncoding a = StableEncoding a deriving (Ord, Eq) +instance J.Encode (StableEncoding PactId) where + build (StableEncoding (PactId pid)) = + J.build pid -- | Stable encoding of `Literal` -- @@ -71,8 +74,8 @@ instance J.Encode (StableEncoding (Guard FullyQualifiedName PactValue)) where -- | Stable encoding of `CapabilityGuard FullyQualifiedName PactValue` instance J.Encode (StableEncoding (CapabilityGuard FullyQualifiedName PactValue)) where - build (StableEncoding (CapabilityGuard name args)) = J.object - [ "cgPactId" J..= (error "a" :: T.Text) -- TODO: Check availability + build (StableEncoding (CapabilityGuard name args mpid)) = J.object + [ "cgPactId" J..= fmap StableEncoding mpid -- TODO: Check availability , "cgArgs" J..= J.Array (StableEncoding <$> args) , "cgName" J..= StableEncoding name ] @@ -150,7 +153,7 @@ instance J.Encode (StableEncoding ModuleName) where instance J.Encode (StableEncoding ModRef) where build (StableEncoding (ModRef mn imp _ref)) = J.object [ "refSpec" J..= J.Array (StableEncoding <$> imp) --- , "refInfo" J..= _modRefInfo o + , "refInfo" J..= J.null , "refName" J..= StableEncoding mn ] {-# INLINABLE build #-} diff --git a/pact-core/Pact/Core/Syntax/Parser.y b/pact-core/Pact/Core/Syntax/Parser.y index e79e136f1..29d47956b 100644 --- a/pact-core/Pact/Core/Syntax/Parser.y +++ b/pact-core/Pact/Core/Syntax/Parser.y @@ -268,7 +268,7 @@ Defcap :: { SpanInfo -> DefCap SpanInfo } DefPact :: { SpanInfo -> DefPact SpanInfo } : defpact IDENT MTypeAnn '(' MArgs ')' MDocOrModel Steps - { DefPact (getIdent $2) $5 $3 (reverse $8) (fst $7) (snd $7) } + { DefPact (getIdent $2) (reverse $5) $3 (reverse $8) (fst $7) (snd $7) } Steps :: { [PactStep SpanInfo] } : Steps Step { $2:$1 } From 38d71eb7645390ba9b2648892924db1097c3b6ea Mon Sep 17 00:00:00 2001 From: jmcardon Date: Thu, 19 Oct 2023 14:43:04 -0400 Subject: [PATCH 6/6] db.repl and hash.repl --- pact-core-tests/Pact/Core/Test/ReplTests.hs | 7 +- pact-core-tests/pact-tests/caps.repl | 1 - pact-core-tests/pact-tests/db.repl | 271 ++++++++++++++++++++ pact-core-tests/pact-tests/hash.repl | 48 ++++ pact-core/Pact/Core/Hash.hs | 4 + pact-core/Pact/Core/IR/Desugar.hs | 53 +++- pact-core/Pact/Core/IR/Eval/RawBuiltin.hs | 3 +- pact-core/Pact/Core/Repl.hs | 2 +- pact-core/Pact/Core/Repl/Compile.hs | 2 +- pact-core/Pact/Core/StableEncoding.hs | 11 +- 10 files changed, 379 insertions(+), 23 deletions(-) create mode 100644 pact-core-tests/pact-tests/db.repl create mode 100644 pact-core-tests/pact-tests/hash.repl diff --git a/pact-core-tests/Pact/Core/Test/ReplTests.hs b/pact-core-tests/Pact/Core/Test/ReplTests.hs index 896887524..cb9a15237 100644 --- a/pact-core-tests/Pact/Core/Test/ReplTests.hs +++ b/pact-core-tests/Pact/Core/Test/ReplTests.hs @@ -49,19 +49,20 @@ runReplTest file src = do gasRef <- newIORef (Gas 0) gasLog <- newIORef Nothing pdb <- mockPactDb - let ee = EvalEnv mempty pdb (EnvData mempty) (Hash "default") def Nothing Transactional mempty + let ee = EvalEnv mempty pdb (EnvData mempty) defaultPactHash def Nothing Transactional mempty + source = SourceCode (takeFileName file) src let rstate = ReplState { _replFlags = mempty , _replEvalState = def , _replPactDb = pdb , _replGas = gasRef , _replEvalLog = gasLog - , _replCurrSource = SourceCode mempty + , _replCurrSource = source , _replEvalEnv = ee , _replTx = Nothing } stateRef <- newIORef rstate - runReplT stateRef (interpretReplProgram (SourceCode src) (const (pure ()))) >>= \case + runReplT stateRef (interpretReplProgram source (const (pure ()))) >>= \case Left e -> let rendered = replError (ReplSource (T.pack file) (decodeUtf8 src)) e in assertFailure (T.unpack rendered) diff --git a/pact-core-tests/pact-tests/caps.repl b/pact-core-tests/pact-tests/caps.repl index 50092a3e7..94ed93afd 100644 --- a/pact-core-tests/pact-tests/caps.repl +++ b/pact-core-tests/pact-tests/caps.repl @@ -845,7 +845,6 @@ (commit-tx) (begin-tx) -; ; (env-exec-config ["DisablePact49"]) ; pact 48 caps (interface ops diff --git a/pact-core-tests/pact-tests/db.repl b/pact-core-tests/pact-tests/db.repl new file mode 100644 index 000000000..e66c387a2 --- /dev/null +++ b/pact-core-tests/pact-tests/db.repl @@ -0,0 +1,271 @@ +; (env-exec-config ["DisablePact44"]) +(env-data { "k": { "keys": ["admin"], "pred": "keys-all" }, + "k2": { "keys": ["admin"], "pred": "keys-all" } }) +(env-keys ["admin"]) +(begin-tx) +(define-keyset 'dbtest-admin (read-keyset "k")) +(module dbtest 'dbtest-admin + + (defschema person + name:string + age:integer + dob:time) + + (deftable persons:{person}) + + (deftable persons2:{person}) + + (defconst ID_A "A") + (defconst ROW_A:object{person} + { 'name:"joe", 'age:46, "dob":(parse-time "%F" "1970-01-01") }) + + (defun read-persons (k) (read persons k)) + + ; (deftable stuff) + + ) +(define-keyset 'dbtest2-admin (read-keyset "k2")) +(module dbtest2 'dbtest2-admin + (defun read-persons2 (k) + (read-persons k))) + +(create-table persons) +; (create-table stuff) + +(commit-tx) +(use dbtest) +(begin-tx) +(use dbtest) +(insert persons ID_A ROW_A) +(expect-failure "dupe key should fail" (insert persons ID_A ROW_A)) +(commit-tx) +(begin-tx) +(use dbtest) +(expect "keys works" [ID_A] (keys persons)) +(expect "txids works" [1] (txids persons 0)) +(expect "txlog works" + [{"value":ROW_A,"key":ID_A,"table":"USER_dbtest_persons"}] + (txlog persons 1)) + +(expect "keylog works" [{"txid": 1, "value": ROW_A}] (keylog persons ID_A 1)) + +(env-exec-config ["DisableHistoryInTransactionalMode"]) +(expect-failure + "txids disabled" + "Operation only permitted in local execution mode" + (txids persons 0)) +(expect-failure + "txlog disabled" + "Operation only permitted in local execution mode" + (txlog persons 1)) +(expect-failure + "keylog disabled" + "Operation only permitted in local execution mode" + (keylog persons ID_A 1)) + + +; (insert stuff "k" { "stuff": { "dec": 1.2, "bool": true, "int": -3, "time": (parse-time "%F" "1970-01-01") } }) +; (expect "object stored as object" "object:*" (typeof (at "stuff" (read stuff "k")))) + +(expect "select works" [ROW_A] (select persons (where 'age (= 46)))) +(expect "select works (miss)" [] (select persons (where 'age (= 45)))) + +(env-keys ["joe"]) + +(expect "read-persons works w/o admin key" ROW_A (read-persons ID_A)) +(expect "read-persons2 works w/o admin key" ROW_A (dbtest2.read-persons2 ID_A)) +(commit-tx) + +;; +;; test admin table guards +(env-exec-config []) ;; clear disable history flag except pre-4.2.0 +(begin-tx) +(use dbtest) +(expect-failure + "write protected by admin key" "Keyset failure (=): 'dbtest-admin" + (write persons "foo" ROW_A)) +(expect-failure + "update protected by admin key" "Keyset failure (=): 'dbtest-admin" + (update persons "foo" ROW_A)) +(expect-failure + "insert protected by admin key" "Keyset failure (=): 'dbtest-admin" + (insert persons "foo" ROW_A)) +(expect-failure + "keys protected by admin key" "Keyset failure (=): 'dbtest-admin" + (keys persons)) +(expect-failure + "txids protected by admin key" "Keyset failure (=): 'dbtest-admin" + (txids persons 0)) +(expect-failure + "txlog protected by admin key" "Keyset failure (=): 'dbtest-admin" + (txlog persons 2)) +(expect-failure + "keylogs protected by admin key" "Keyset failure (=): 'dbtest-admin" + (keylog persons "" 2)) +(expect-failure + "read protected by admin key" "Keyset failure (=): 'dbtest-admin" + (read persons ID_A)) +(expect-failure + "with-read protected by admin key" "Keyset failure (=): 'dbtest-admin" + (with-read persons ID_A { 'name:= name } name)) +(expect-failure + "with-default-read protected by admin key" "Keyset failure (=): 'dbtest-admin" + (with-default-read persons ID_A { 'name: "stu" } { 'name:= name } name)) +(expect-failure + "select protected by admin key" "Keyset failure (=): 'dbtest-admin" + (select persons (constantly true))) +(expect-failure + "keys protected by admin key" "Keyset failure (=): 'dbtest-admin" + (keys persons)) +(expect-failure + "create-table protected by admin key" "Keyset failure (=): 'dbtest-admin" + (create-table persons2)) + +;; just making sure this doesn't blow up, output is still TBD on better Term output in general +(describe-table persons) + +(commit-tx) +;; test disabling admin table guards +(env-exec-config ["AllowReadInLocal"]) +(use dbtest) +(expect-failure + "write protected by admin key in local" "Keyset failure (=): 'dbtest-admin" + (write persons "foo" ROW_A)) +(expect-failure + "update protected by admin key in local" "Keyset failure (=): 'dbtest-admin" + (update persons "foo" ROW_A)) +(expect-failure + "insert protected by admin key in local" "Keyset failure (=): 'dbtest-admin" + (insert persons "foo" ROW_A)) +(expect + "keys allowed in local" [ID_A] + (keys persons)) +(expect + "txids allowed in local" [1] + (txids persons 0)) +(expect + "txlog allowed in local" [ID_A] + (map (at "key") (txlog persons 1))) +(expect + "keylogs allowed in local" [1] + (map (at "txid") (keylog persons ID_A 1))) +(expect + "read allowed in local" "joe" + (at "name" (read persons ID_A))) +(expect + "with-read allowed in local" "joe" + (with-read persons ID_A { 'name:= name } name)) +(expect + "with-default-read allowed in local" "stu" + (with-default-read persons "zzz" { 'name: "stu" } { 'name:= name } name)) +(expect + "select allowed in local" [46] + (map (at "age") (select persons (constantly true)))) +(expect + "keys allowed in local" [ID_A] + (keys persons)) +(expect-failure + "create-table protected by admin key in local" "Keyset failure (=): 'dbtest-admin" + (create-table persons2)) + +;; test nested commits + +(begin-tx) +; (env-enable-repl-natives true) +(module nested-tx G + (defcap G () true) + (defschema s x:integer) + (deftable t:{s}) + (defun test-nested-tx () + (begin-tx) + (insert t "a" { 'x: 1 }) + (commit-tx) + (begin-tx) + (insert t "b" { 'x: 2 }) + (rollback-tx) + (expect "2nd insert rolled back" ["a"] + (keys t)))) + +(create-table t) +(commit-tx) + +(nested-tx.test-nested-tx) + +;; fold-db tests + key sort guarantees +(env-exec-config []) + +(module fdb G + (defcap G () true) + (defschema fdb-test a:integer b:integer) + (deftable fdb-tbl:{fdb-test}) +) + +(create-table fdb-tbl) +;; inserts shuffled to test key sort guarantees: +;; (insert fdb-tbl 'a {'a:1, 'b:1}) +;; (insert fdb-tbl 'b {'a:2, 'b:2}) +;; (insert fdb-tbl 'c {'a:3, 'b:3}) +;; (insert fdb-tbl 'd {'a:4, 'b:4}) +(insert fdb-tbl 'b {'a:2, 'b:2}) +(insert fdb-tbl 'd {'a:4, 'b:4}) +(insert fdb-tbl 'c {'a:3, 'b:3}) +(insert fdb-tbl 'a {'a:1, 'b:1}) + + +(expect + "fold-db query filters correctly by key" + ["a" "b"] + (let* + ((qry (lambda (k o) (< k "c"))) + (consume (lambda (k o) k)) + ) + (fold-db fdb-tbl (qry) (consume)) + )) + +(expect + "fold-db query filters correctly by key" + ["a" "b"] + (let* + ((qry (lambda (k o) (< k "c"))) + (consume (lambda (k o) k)) + ) + (fold-db fdb-tbl (qry) (consume)) + )) + +(expect + "fold-db query handles key/obj transform correctly" + [["a" 1] ["b" 2]] + (let* + ((qry (lambda (k o) (< k "c"))) + (consume (lambda (k o) [k (at 'a o)])) + ) + (fold-db fdb-tbl (qry) (consume)) + )) + +(expect + "fold-db spits out all entries on true qry" + [{'entry:'a, 'value:{'a:1, 'b:1}} {'entry:'b, 'value:{'a:2, 'b:2}} {'entry:'c, 'value:{'a:3, 'b:3}} {'entry:'d, 'value:{'a:4, 'b:4}}] + (let* + ((qry (lambda (k o) true)) + (consume (lambda (k o) {'entry:k, 'value:o})) + ) + (fold-db fdb-tbl (qry) (consume)) + )) + +(expect + "sorted output for keys native for pact 4.2.0" + ["a" "b" "c" "d"] + (keys fdb-tbl) + ) + +(expect + "sorted output based on keys from select for pact 4.2.0" + [{"a": 1} {"a": 2} {"a": 3} {"a": 4}] + (select fdb-tbl ['a] (constantly true)) + ) + +(expect + "fold-db query handles key/obj transform correctly: inline lambdas version" + [["a" 1] ["b" 2]] + (fold-db fdb-tbl (lambda (k o) (< k "c")) (lambda (k o) [k (at 'a o)])) + ) diff --git a/pact-core-tests/pact-tests/hash.repl b/pact-core-tests/pact-tests/hash.repl new file mode 100644 index 000000000..737042892 --- /dev/null +++ b/pact-core-tests/pact-tests/hash.repl @@ -0,0 +1,48 @@ +(expect "repl starts with empty hash" (hash "") (tx-hash)) +(env-hash (hash "hello")) +(expect "hash roundtrip" (hash "hello") (tx-hash)) + +(begin-tx) +(interface iface + (defun f:bool (a:module{iface})) + ) + +(module my-mod G + (defcap G() true) + + (defschema hashes h:string) + (deftable hashes-table:{hashes}) + (implements iface) + + (defun get-hash (k:string) + (at "h" (read hashes-table k))) + + (defun f:bool (a:module{iface}) true) + + (defun insert-hash (k:string h:string) + (write hashes-table k {"h":h}) + (concat ["added hash ", h, " to table"]) + ) + ) + +(create-table hashes-table) + +; The module hash constants used here +; come from old prod pact. We ensure they match due to this +(insert-hash "a" (hash my-mod)) +(insert-hash "b" (hash my-mod)) +(insert-hash "c" (hash [my-mod, {'a:my-mod}, (create-user-guard (f my-mod))])) +(insert-hash "d" (hash [my-mod, {'a:my-mod}, (create-user-guard (f my-mod))])) + +(let* + ( (h1 (get-hash "a")) + (h2 (get-hash "b")) + (h3 (get-hash "c")) + (h4 (get-hash "d")) + ) + (enforce (= h1 "vediBPdnKkzahPDZY2UF_hkS8i7pIXqwsCj925gLng8") "h1 does not match expected value") + (enforce (= h3 "_c98nMfdnxKUdjoE7EQR9RUHfqJDJjlljL2JGGwUqiA") "h3 does not match expected value") + (expect "hashes match post-fork - simple case" true (enforce (= h1 h2) "boom")) + (expect "hashes match post-fork - recursive case" true (enforce (= h1 h2) "boom")) + ) +(commit-tx) diff --git a/pact-core/Pact/Core/Hash.hs b/pact-core/Pact/Core/Hash.hs index d78cf040b..617e02730 100644 --- a/pact-core/Pact/Core/Hash.hs +++ b/pact-core/Pact/Core/Hash.hs @@ -24,6 +24,7 @@ module Pact.Core.Hash , decodeBase64UrlUnpadded , toB64UrlUnpaddedText , fromB64UrlUnpaddedText +, defaultPactHash ) where import Control.DeepSeq @@ -114,3 +115,6 @@ fromB64UrlUnpaddedText bs = case decodeBase64UrlUnpadded bs of newtype ModuleHash = ModuleHash { _mhHash :: Hash } deriving (Eq, Ord, Show) deriving newtype (NFData) + +defaultPactHash :: Hash +defaultPactHash = pactHash "" diff --git a/pact-core/Pact/Core/IR/Desugar.hs b/pact-core/Pact/Core/IR/Desugar.hs index 51b5b84ba..9715c24f9 100644 --- a/pact-core/Pact/Core/IR/Desugar.hs +++ b/pact-core/Pact/Core/IR/Desugar.hs @@ -736,13 +736,41 @@ loadTopLevelMembers i mimports mdata binds = case mdata of (rsLoaded . loToplevel) %= (`M.union` loadedDeps) pure (M.union depMap binds) +-- | Resolve a module name, return the implemented members as well if any +-- including all current +resolveModuleName :: (MonadRenamer b i m) => i -> ModuleName -> m (ModuleName, [ModuleName]) +resolveModuleName i mn = + view reCurrModule >>= \case + Just (currMod, imps) | currMod == mn -> pure (currMod, imps) + _ -> resolveModuleData mn i >>= \case + ModuleData md _ -> do + let implementeds = view mImplements md + pure (mn, implementeds) + -- todo: error type here + InterfaceData iface _ -> + throwDesugarError (InvalidModuleReference (_ifName iface)) i + +-- | Resolve a module name, return the implemented members as well if any +-- including all current +resolveInterfaceName :: (MonadRenamer b i m) => i -> ModuleName -> m (ModuleName) +resolveInterfaceName i mn = + view reCurrModule >>= \case + Just (currMod, _imps) | currMod == mn -> pure currMod + _ -> resolveModuleData mn i >>= \case + ModuleData _ _ -> + throwDesugarError (InvalidModuleReference mn) i + -- todo: error type here + InterfaceData _ _ -> + pure mn -resolveModuleName + +-- mn implementeds +resolveModuleData :: (MonadRenamer b i m) => ModuleName -> i -> m (ModuleData b i) -resolveModuleName mn i = +resolveModuleData mn i = use (rsLoaded . loModules . at mn) >>= \case Just md -> pure md Nothing -> @@ -884,7 +912,7 @@ renameType i = \case Lisp.TyList ty -> TyList <$> renameType i ty Lisp.TyModRef tmr -> - TyModRef tmr <$ resolveModuleName tmr i + TyModRef tmr <$ resolveInterfaceName i tmr Lisp.TyKeyset -> pure TyGuard Lisp.TyObject pn -> TyObject <$> resolveSchema pn @@ -1248,13 +1276,16 @@ resolveBare (BareName bn) i = views reBinds (M.lookup bn) >>= \case Just (currMod, imps) | currMod == mn -> pure (Name bn (NModRef mn imps), Nothing) _ -> do - resolveModuleName mn i >>= \case - ModuleData md _ -> do - let implementeds = view mImplements md - pure (Name bn (NModRef mn implementeds), Nothing) - -- todo: error type here - InterfaceData iface _ -> - throwDesugarError (InvalidModuleReference (_ifName iface)) i + (mn', imps) <- resolveModuleName i mn + pure (Name bn (NModRef mn' imps), Nothing) + + -- resolveModuleData mn i >>= \case + -- ModuleData md _ -> do + -- let implementeds = view mImplements md + -- pure (Name bn (NModRef mn implementeds), Nothing) + -- -- todo: error type here + -- InterfaceData iface _ -> + -- throwDesugarError (InvalidModuleReference (_ifName iface)) i resolveQualified :: (MonadRenamer b i m) @@ -1332,7 +1363,7 @@ handleImport -> Import -> m (Map Text (NameKind, Maybe DefKind)) handleImport info binds (Import mn mh imported) = do - mdata <- resolveModuleName mn info + mdata <- resolveModuleData mn info let imported' = S.fromList <$> imported mdhash = view mdModuleHash mdata case mh of diff --git a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs index 2a6b7153b..680cd15c1 100644 --- a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs +++ b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs @@ -587,7 +587,6 @@ enforceTopLevelOnly :: (IsBuiltin b, MonadEval b i m) => i -> b -> m () enforceTopLevelOnly info b = do s <- useEvalState esStack when (not (null s)) $ do - liftIO $ print s throwExecutionError info (NativeIsTopLevelOnly (builtinName b)) ----------------------------------- @@ -1276,7 +1275,7 @@ coreHash :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m coreHash = \info b cont handler _env -> \case [VString s] -> returnCEKValue cont handler (go (T.encodeUtf8 s)) - [VPactValue pv] -> + [VPactValue pv] -> do returnCEKValue cont handler (go (encodeStable pv)) args -> argsError info b args where diff --git a/pact-core/Pact/Core/Repl.hs b/pact-core/Pact/Core/Repl.hs index a011ee7ae..7da6a7e59 100644 --- a/pact-core/Pact/Core/Repl.hs +++ b/pact-core/Pact/Core/Repl.hs @@ -48,7 +48,7 @@ main = do pdb <- mockPactDb g <- newIORef mempty evalLog <- newIORef Nothing - let ee = EvalEnv mempty pdb (EnvData mempty) (Hash "default") def Nothing Transactional mempty + let ee = EvalEnv mempty pdb (EnvData mempty) defaultPactHash def Nothing Transactional mempty es = EvalState (CapState [] mempty mempty mempty) [] [] mempty Nothing ref <- newIORef (ReplState mempty pdb es ee g evalLog defaultSrc Nothing) runReplT ref (runInputT replSettings loop) >>= \case diff --git a/pact-core/Pact/Core/Repl/Compile.hs b/pact-core/Pact/Core/Repl/Compile.hs index f48b0d37c..c323b0965 100644 --- a/pact-core/Pact/Core/Repl/Compile.hs +++ b/pact-core/Pact/Core/Repl/Compile.hs @@ -67,7 +67,7 @@ loadFile loc display = do defaultEvalEnv :: PactDb b i -> EvalEnv b i defaultEvalEnv pdb = - EvalEnv mempty pdb (EnvData mempty) (Hash "default") def Nothing Transactional mempty + EvalEnv mempty pdb (EnvData mempty) defaultPactHash def Nothing Transactional mempty interpretReplProgram :: SourceCode diff --git a/pact-core/Pact/Core/StableEncoding.hs b/pact-core/Pact/Core/StableEncoding.hs index 06332e6ed..ddf8c8345 100644 --- a/pact-core/Pact/Core/StableEncoding.hs +++ b/pact-core/Pact/Core/StableEncoding.hs @@ -81,6 +81,10 @@ instance J.Encode (StableEncoding (CapabilityGuard FullyQualifiedName PactValue) ] {-# INLINABLE build #-} +instance J.Encode (StableEncoding QualifiedName) where + build (StableEncoding qn) = J.build (renderQualName qn) + {-# INLINABLE build #-} + -- | Stable encoding of `FullyQualifiedName` instance J.Encode (StableEncoding FullyQualifiedName) where build (StableEncoding (FullyQualifiedName (ModuleName mn mns) n (ModuleHash mh))) = J.build t @@ -100,7 +104,7 @@ instance J.Encode (StableEncoding ModuleGuard) where instance J.Encode (StableEncoding (UserGuard FullyQualifiedName PactValue)) where build (StableEncoding (UserGuard fun args)) = J.object [ "args" J..= J.array (StableEncoding <$> args) - , "fun" J..= StableEncoding fun + , "fun" J..= StableEncoding (fqnToQualName fun) ] {-# INLINABLE build #-} @@ -152,8 +156,7 @@ instance J.Encode (StableEncoding ModuleName) where -- | Stable encoding of `ModRef` instance J.Encode (StableEncoding ModRef) where build (StableEncoding (ModRef mn imp _ref)) = J.object - [ "refSpec" J..= J.Array (StableEncoding <$> imp) - , "refInfo" J..= J.null + [ "refSpec" J..= Just (J.Array (StableEncoding <$> imp)) , "refName" J..= StableEncoding mn ] {-# INLINABLE build #-} @@ -187,6 +190,6 @@ instance J.Encode (StableEncoding PactValue) where instance J.Encode (StableEncoding (PactContinuation FullyQualifiedName PactValue)) where build (StableEncoding (PactContinuation name args))= J.object [ "args" J..= J.Array (StableEncoding <$> args) - , "def" J..= J.build (StableEncoding name) + , "def" J..= J.build (StableEncoding (fqnToQualName name)) ] {-# INLINABLE build #-}