spv support for core

pact-tng.cabal

@@ -172,6 +172,7 @@ library
     Pact.Core.RuntimeParsers
     Pact.Core.Evaluate
     Pact.Core.Scheme
+    Pact.Core.SPV
     Pact.Core.Repl
     Pact.Core.SizeOf
     Pact.Core.StackFrame

pact/Pact/Core/Builtin.hs

@@ -213,6 +213,7 @@ data CoreBuiltin
   | CoreDec
   | CoreCond
   | CoreIdentity
+  | CoreVerifySPV
   deriving (Eq, Show, Ord, Bounded, Enum, Generic)
 
 instance NFData CoreBuiltin
@@ -380,9 +381,10 @@ coreBuiltinToText = \case
   CoreDec -> "dec"
   CoreCond -> "cond"
   CoreIdentity -> "identity"
+  CoreVerifySPV -> "verify-spv"
 
 -- | Our `CoreBuiltin` user-facing representation.
--- note: `coreBuiltinToUserText`
+-- note: `coreBuiltinToUserText` is primarily for pretty printing
 coreBuiltinToUserText :: CoreBuiltin -> Text
 coreBuiltinToUserText = \case
   -- Addition
@@ -526,6 +528,7 @@ coreBuiltinToUserText = \case
   CoreDec -> "dec"
   CoreCond -> "cond"
   CoreIdentity -> "identity"
+  CoreVerifySPV -> "verify-spv"
 
 instance IsBuiltin CoreBuiltin where
   builtinName = NativeName . coreBuiltinToText
@@ -675,6 +678,7 @@ instance IsBuiltin CoreBuiltin where
     CoreDec -> 1
     CoreCond -> 1
     CoreIdentity -> 1
+    CoreVerifySPV -> 2
 
 
 coreBuiltinNames :: [Text]

pact/Pact/Core/Environment/Types.hs

@@ -17,7 +17,7 @@ module Pact.Core.Environment.Types
  ( EvalEnv(..)
  , eeMsgSigs, eePactDb
  , eeHash, eeMsgBody
- , eeDefPactStep
+ , eeDefPactStep, eeSPVSupport
  , eePublicData, eeMode, eeFlags
  , eeNatives, eeGasModel
  , eeNamespacePolicy, eeGasRef
@@ -79,6 +79,7 @@ import Pact.Core.Namespace
 import Pact.Core.SizeOf
 import Pact.Core.StackFrame
 import Pact.Core.Builtin (IsBuiltin)
+import Pact.Core.SPV
 
 -- | Execution flags specify behavior of the runtime environment,
 -- with an orientation towards some alteration of a default behavior.
@@ -140,6 +141,7 @@ data EvalEnv b i
   -- ^ The gas ref
   , _eeGasModel :: GasModel b
   -- ^ The current gas model
+  , _eeSPVSupport :: SPVSupport
   } deriving (Generic)
 
 instance (NFData b, NFData i) => NFData (EvalEnv b i)
@@ -230,4 +232,5 @@ defaultEvalEnv pdb m = do
     , _eeNamespacePolicy = SimpleNamespacePolicy
     , _eeGasRef = gasRef
     , _eeGasModel = freeGasModel
+    , _eeSPVSupport = noSPVSupport
     }

pact/Pact/Core/Errors.hs

@@ -344,6 +344,7 @@ data EvalError
   | EnforcePactVersionFailure V.Version (Maybe V.Version)
   | EnforcePactVersionParseFailure Text
   | RuntimeRecursionDetected QualifiedName
+  | SPVVerificationFailure Text
   deriving (Show, Generic)
 
 instance NFData EvalError
@@ -480,6 +481,7 @@ instance Pretty EvalError where
     e@YieldProvenanceDoesNotMatch{} -> pretty (show e)
     e@MismatchingKeysetNamespace{} -> pretty (show e)
     e@RuntimeRecursionDetected{} -> pretty (show e)
+    e@SPVVerificationFailure{} -> pretty (show e)
 
 
 

pact/Pact/Core/Evaluate.hs

@@ -51,6 +51,7 @@ import Pact.Core.Names
 import Pact.Core.Guards
 import Pact.Core.Namespace
 import Pact.Core.IR.Desugar
+import Pact.Core.SPV
 import qualified Pact.Core.IR.Eval.CEK as Eval
 import qualified Pact.Core.Syntax.Lexer as Lisp
 import qualified Pact.Core.Syntax.Parser as Lisp
@@ -108,12 +109,12 @@ setupEvalEnv
   -> ExecutionMode -- <- we have this
   -> MsgData -- <- create at type for this
   -- -> GasEnv -- <- also have this, use constant gas model
-  -> NamespacePolicy -- <- also have this, as-is
-  -- -> SPVSupport -- <- WIP: Ignore for now
-  -> PublicData -- <- we have this
+  -> NamespacePolicy
+  -> SPVSupport
+  -> PublicData
   -> S.Set ExecutionFlag
   -> IO (EvalEnv CoreBuiltin ())
-setupEvalEnv pdb mode msgData np pd efs = do
+setupEvalEnv pdb mode msgData np spv pd efs = do
   gasRef <- newIORef mempty
   pure $ EvalEnv
     { _eeMsgSigs = mkMsgSigs $ mdSigners msgData
@@ -128,6 +129,7 @@ setupEvalEnv pdb mode msgData np pd efs = do
     , _eeNamespacePolicy = np
     , _eeGasRef = gasRef
     , _eeGasModel = freeGasModel
+    ,_eeSPVSupport = spv
     }
   where
   mkMsgSigs ss = M.fromList $ map toPair ss

pact/Pact/Core/Gas/TableGasModel.hs

@@ -483,6 +483,7 @@ nativeGasTable = MilliGas . \case
     basicWorkGas
   CoreCond -> basicWorkGas
   CoreIdentity -> basicWorkGas
+  CoreVerifySPV -> 100_000
 
 replNativeGasTable :: ReplBuiltin CoreBuiltin -> MilliGas
 replNativeGasTable = \case

pact/Pact/Core/IR/Eval/CoreBuiltin.hs

@@ -76,6 +76,7 @@ import Pact.Core.IR.Eval.Runtime
 import Pact.Core.StableEncoding
 import Pact.Core.IR.Eval.CEK
 import Pact.Core.SizeOf
+import Pact.Core.SPV
 
 import qualified Pact.Core.Pretty as Pretty
 import qualified Pact.Core.Principal as Pr
@@ -1840,6 +1841,35 @@ poseidonHash info _b _cont _handler _env _args = failInvariant info "crypto disa
 
 #endif
 
+---
+-- SPV
+--
+
+-- verifySPV :: NativeDef
+-- verifySPV =
+--   defRNative "verify-spv" verifySPV'
+--   (funType (tTyObject (mkTyVar' "out"))
+--    [("type", tTyString),
+--     ("payload", tTyObject (mkTyVar' "in"))])
+--   [LitExample "(verify-spv \"TXOUT\" (read-msg \"proof\"))"]
+--   "Performs a platform-specific spv proof of type TYPE on PAYLOAD. \
+--   \The format of the PAYLOAD object depends on TYPE, as does the \
+--   \format of the return object. Platforms such as Chainweb will \
+--   \document the specific payload types and return values."
+--   where
+--     verifySPV' i [TLitString proofType, TObject o _] = do
+--       view eeSPVSupport >>= \(SPVSupport f _) -> liftIO (f proofType o) >>= \r -> case r of
+--         Left err -> evalError' i $ "SPV verify failed: " <> pretty err
+--         Right o' -> return $ TObject o' def
+--     verifySPV' i as = argsError i as
+coreVerifySPV :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m
+coreVerifySPV info b cont handler _env = \case
+  [VString proofType, VObject o] -> do
+    SPVSupport f _ <- viewEvalEnv eeSPVSupport
+    liftIO (f proofType (ObjectData o)) >>= \case
+      Left err -> throwExecutionError info (SPVVerificationFailure err)
+      Right (ObjectData o') -> returnCEKValue cont handler (VObject o')
+  args -> argsError info b args
 
 -----------------------------------
 -- Builtin exports
@@ -2002,3 +2032,4 @@ coreBuiltinRuntime = \case
   CoreDec -> coreDec
   CoreCond -> coreCond
   CoreIdentity -> coreIdentity
+  CoreVerifySPV -> coreVerifySPV

pact/Pact/Core/SPV.hs

@@ -0,0 +1,38 @@
+module Pact.Core.SPV
+ ( ContProof(..)
+ , SPVSupport(..)
+ , noSPVSupport)where
+
+import Data.Text(Text)
+import Data.ByteString(ByteString)
+import GHC.Generics
+import Control.DeepSeq
+
+import Pact.Core.DefPacts.Types
+import Pact.Core.PactValue
+
+newtype ContProof = ContProof { _contProof :: ByteString }
+  deriving (Eq, Ord, Show, Generic)
+
+
+instance NFData ContProof
+
+-- | Backend for SPV support
+data SPVSupport = SPVSupport
+  { _spvSupport :: !(Text -> (ObjectData PactValue) -> IO (Either Text (ObjectData PactValue)))
+    -- ^ Attempt to verify an SPV proof of a given type,
+    -- given a payload object. On success, returns the
+    -- specific data represented by the proof.
+  , _spvVerifyContinuation :: !(ContProof -> IO (Either Text DefPactExec))
+    -- ^ Attempt to verify an SPV proof of a continuation given
+    -- a continuation payload object bytestring. On success, returns
+    -- the 'PactExec' associated with the proof.
+  } deriving (Generic)
+
+instance NFData SPVSupport
+
+noSPVSupport :: SPVSupport
+noSPVSupport = SPVSupport spv vcon
+  where
+    spv = \_ _ -> return $ Left "SPV verification not supported"
+    vcon = \_ -> return $ Left "Cross-chain continuations not supported"

pact/Pact/Core/Serialise/CBOR_V1.hs

@@ -683,6 +683,7 @@ instance Serialise CoreBuiltin where
     CoreFloorPrec -> encodeWord 127
     CoreCond -> encodeWord 128
     CoreIdentity -> encodeWord 129
+    CoreVerifySPV -> encodeWord 130
 
   decode = decodeWord >>= \case
     0 -> pure CoreAdd