diff --git a/.gitignore b/.gitignore index 29befa462..2db79ee6e 100644 --- a/.gitignore +++ b/.gitignore @@ -34,4 +34,5 @@ hie.yaml commands.sqlite cabal.project.local* /golden/lcov/actual -.DS_Store \ No newline at end of file +.DS_Store +.ghci_history diff --git a/CHANGELOG.md b/CHANGELOG.md index 37e3fdde5..5239d15ab 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +Unreleased +--- +### Features +- Support for verifier plugins (#1324) + + 4.10.0 --- ### Features diff --git a/README.md b/README.md index d27411f51..eef15fc6c 100644 --- a/README.md +++ b/README.md @@ -252,7 +252,7 @@ console> pact --serve --help Config file is YAML format with the following properties: port - HTTP server port persistDir - Directory for database files. - If ommitted, runs in-memory only. + If omitted, runs in-memory only. logDir - Directory for HTTP logs pragmas - SQLite pragmas to use with persistence DBs verbose - [True|False] Provide extra logging information diff --git a/cabal.project b/cabal.project index a6435cf99..aa61dfae0 100644 --- a/cabal.project +++ b/cabal.project @@ -1,17 +1,20 @@ packages: . +package pact + ghc-options: -Wno-missed-extra-shared-lib + +source-repository-package + type: git + location: https://github.com/kadena-io/pact-json.git + tag: 1d260bfaa48312b54851057885de4c43c420e35f + --sha256: 0fzq4mzaszj5clvixx9mn1x6r4dcrnwvbl2znd0p5mmy5h2jr0hh + -- temporary upper bounds constraints: sbv <10 -- test upper bounds constraints: hspec-golden <0.2, -source-repository-package - type: git - tag: e43073d0b8d89d9b300980913b842f4be339846d - location: https://github.com/kadena-io/pact-json - --sha256: sha256-ZWbAId0JBaxDsYhwcYUyw04sjYstXyosSCenzOvUxsQ= - -- These packages are tightly bundled with GHC. The rules ensure that -- our builds use the version that ships with the GHC version that is -- used for the build. @@ -38,6 +41,9 @@ allow-newer: servant:* -- Required by trifecta (e.g. to allow mtl >=2.3) allow-newer: trifecta:* --- servant-0.20 does not yet support aeson-2.2 --- -constraints: aeson <2.2 +source-repository-package + type: git + location: https://github.com/kadena-io/kadena-ethereum-bridge.git + tag: ffbf20e9f0430b95448bd66c6b1b530864397fb3 + --sha256: sha256-xdawv/tdjh61MbJKcBqm9Fje36+gVljuZsAxOTX1gP0= + diff --git a/docs/en/pact-functions.md b/docs/en/pact-functions.md index 32d643d37..db75b640f 100644 --- a/docs/en/pact-functions.md +++ b/docs/en/pact-functions.md @@ -5,14 +5,14 @@ Constant denoting the ASCII charset -Constant: +Constant:   `CHARSET_ASCII:integer = 0` ### CHARSET_LATIN1 {#CHARSET_LATIN1} Constant denoting the Latin-1 charset ISO-8859-1 -Constant: +Constant:   `CHARSET_LATIN1:integer = 1` ### at {#at} @@ -765,7 +765,7 @@ Top level only: this function will fail if used in module code. Select rows from TABLE using QRY as a predicate with both key and value, and then accumulate results of the query in CONSUMER. Output is sorted by the ordering of keys. ```lisp -(let* +(let* ((qry (lambda (k obj) true)) ;; select all rows (f (lambda (k obj) [(at 'firstName obj), (at 'b obj)])) ) @@ -924,7 +924,7 @@ pact> (add-time (time "2016-07-22T12:00:00Z") 15) *n* `integer` *→* `decimal` -N days, for use with 'add-time' +N days, for use with 'add-time' ```lisp pact> (add-time (time "2016-07-22T12:00:00Z") (days 1)) "2016-07-23T12:00:00Z" @@ -962,7 +962,7 @@ pact> (format-time "%F" (time "2016-07-22T12:00:00Z")) *n* `integer` *→* `decimal` -N hours, for use with 'add-time' +N hours, for use with 'add-time' ```lisp pact> (add-time (time "2016-07-22T12:00:00Z") (hours 1)) "2016-07-22T13:00:00Z" @@ -976,7 +976,7 @@ pact> (add-time (time "2016-07-22T12:00:00Z") (hours 1)) *n* `integer` *→* `decimal` -N minutes, for use with 'add-time'. +N minutes, for use with 'add-time'. ```lisp pact> (add-time (time "2016-07-22T12:00:00Z") (minutes 1)) "2016-07-22T12:01:00Z" @@ -1000,7 +1000,7 @@ pact> (parse-time "%F" "2016-09-12") *utcval* `string` *→* `time` -Construct time from UTCVAL using ISO8601 format (%Y-%m-%dT%H:%M:%SZ). +Construct time from UTCVAL using ISO8601 format (%Y-%m-%dT%H:%M:%SZ). ```lisp pact> (time "2016-07-22T11:26:35Z") "2016-07-22T11:26:35Z" @@ -1582,6 +1582,17 @@ Execute GUARD, or defined keyset KEYSETNAME, to enforce desired predicate logic. ``` +### enforce-verifier {#enforce-verifier} + +*verifiername* `string` *→* `bool` + + +Enforce that a verifier is in scope. +```lisp +(enforce-verifier 'COOLZK) +``` + + ### install-capability {#install-capability} *capability* ` -> bool` *→* `string` @@ -1804,6 +1815,19 @@ pact> (poseidon-hash-hack-a-chain 1 2 3 4 5 6 7 8) 18604317144381847857886385684060986177838410221561136253933256952257712543953 ``` +## Hyperlane {#Hyperlane} + +### hyperlane-message-id {#hyperlane-message-id} + +*x* `object:*` *→* `string` + + +Get the Message Id of a Hyperlane Message object. +```lisp +pact> (hyperlane-message-id {"destinationDomain": 1,"nonce": 325,"originDomain": 626,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F","sender": "0x6b622d746f6b656e2d726f75746572","tokenMessage": {"amount": 10000000000000000000.0,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F"},"version": 1}) +"0x97d98aa7fdb548f43c9be37aaea33fca79680247eb8396148f1df10e6e0adfb7" +``` + ## REPL-only functions {#repl-lib} The following functions are loaded automatically into the interactive REPL, or within script files with a `.repl` extension. They are not available for blockchain-based execution. @@ -1947,7 +1971,7 @@ Retreive any accumulated events and optionally clear event state. Object returne *→* `[string]` -Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact410","DisablePact411","DisablePact42","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePact47","DisablePact48","DisablePact49","DisablePactEvents","DisableRuntimeReturnTypeChecking","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"] +Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact410","DisablePact42","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePact47","DisablePact48","DisablePact49","DisablePactEvents","DisableRuntimeReturnTypeChecking","DisableVerifiers","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"] ```lisp pact> (env-exec-config ['DisableHistoryInTransactionalMode]) (env-exec-config) ["DisableHistoryInTransactionalMode"] @@ -2081,6 +2105,17 @@ Set a flag to simulate on-chain behavior that differs from the repl, in particul ``` +### env-verifiers {#env-verifiers} + +*verifiers* `[object:*]` *→* `string` + + +Set transaction verifier names and capabilities. VERIFIERS is a list of objects with "name" specifying the verifier name, and "caps" specifying a list of associated capabilities. +```lisp +(env-verifiers [({'name: "COOLZK", 'caps: [(accounts.USER_GUARD "my-account")]}, {'name: "HYPERCHAIN-BRIDGE", 'caps: [(bridge.MINT "mycoin" 20)]}]) +``` + + ### expect {#expect} *doc* `string` *expected* `` *actual* `` *→* `string` diff --git a/docs/en/pact-reference.md b/docs/en/pact-reference.md index 86e2f70cc..4007d10ad 100644 --- a/docs/en/pact-reference.md +++ b/docs/en/pact-reference.md @@ -624,7 +624,7 @@ Modules may be imported at a namespace, and interfaces my be implemented in a si #### Example: appending code to a namespace -If one is simply appending code to an existing namespace, then the namespace prefix in the fully qualified name may be ommitted, as using a namespace works in a similar way to importing a module: all toplevel definitions within a namespace are brought into scope when `(namespace 'my-namespace)` is declared. Continuing from the previous example: +If one is simply appending code to an existing namespace, then the namespace prefix in the fully qualified name may be omitted, as using a namespace works in a similar way to importing a module: all toplevel definitions within a namespace are brought into scope when `(namespace 'my-namespace)` is declared. Continuing from the previous example: ```lisp pact> (my-other-namespace.my-other-module.more-hello 3) diff --git a/docs/en/pact-reference.rst b/docs/en/pact-reference.rst index 62d965196..5524e4545 100644 --- a/docs/en/pact-reference.rst +++ b/docs/en/pact-reference.rst @@ -806,7 +806,7 @@ Example: appending code to a namespace ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If one is simply appending code to an existing namespace, then the -namespace prefix in the fully qualified name may be ommitted, as using a +namespace prefix in the fully qualified name may be omitted, as using a namespace works in a similar way to importing a module: all toplevel definitions within a namespace are brought into scope when ``(namespace 'my-namespace)`` is declared. Continuing from the previous diff --git a/flake.nix b/flake.nix index 5fe7f4e52..87324d690 100644 --- a/flake.nix +++ b/flake.nix @@ -33,7 +33,7 @@ }; shell.buildInputs = with pkgs; [ zlib - z3 + z3_4_11 pkgconfig (python3.withPackages (ps: [ps.sphinx ps.sphinx_rtd_theme])) pandoc perl diff --git a/golden/gas-model/golden b/golden/gas-model/golden index fd8b74a79..3f2ca1ce8 100644 --- a/golden/gas-model/golden +++ b/golden/gas-model/golden @@ -597,6 +597,10 @@ "8520f0098930a754748b7ddcb43ef75a0dbf3a0d26381af4eba4a98eaa9b4e6a" "77076d0a7318a57d3c16c17251b26645df4c2f87ebc0992ab177fba51db92c2a") - 29 +- - |- + (hyperlane-message-id {"destinationDomain": 1,"nonce": 325,"originDomain": 626,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F","sender": "0x6b622d746f6b656e2d726f75746572","tokenMessage": {"amount": 10000000000000000000.0,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F"},"version": 1}) + (hyperlane-message-id {"destinationDomain": 1,"nonce": 325,"originDomain": 626,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F","sender": "0x6b622d746f6b656e2d726f75746572","tokenMessage": {"amount": 10000000000000000000.0,"recipient": "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"},"version": 1}) + - 4 - - (^ 2 longNumber) - 4 - - (^ 2 medNumber) @@ -999,6 +1003,16 @@ - 2 - - (>= (time "2016-07-22T12:00:00Z") (time "2018-07-22T12:00:00Z")) - 6 +- - |- + (module m GOV + (defcap GOV () true) + + (defcap GOOD () (enforce-verifier 'HYPERLANE)) + + (defun good () (with-capability (GOOD) 1)) + ) + (good) + - 59 - - (take 1 longNumberList) - 3 - - (take 1 medNumberList) diff --git a/pact.cabal b/pact.cabal index 2ba28fcb4..8fba2af61 100644 --- a/pact.cabal +++ b/pact.cabal @@ -96,6 +96,7 @@ library cbits/musl/sqrt_data.c exposed-modules: Crypto.Hash.Blake2Native + Crypto.Hash.HyperlaneMessageId Crypto.Hash.PoseidonNative Pact.Analyze.Remote.Types Pact.ApiReq @@ -181,6 +182,7 @@ library Pact.Types.Type Pact.Types.Typecheck Pact.Types.Util + Pact.Types.Verifier Pact.Types.Version Pact.Utils.Servant @@ -223,6 +225,7 @@ library , filepath >=1.4.1.0 , groups , hashable >=1.4 + , ethereum >= 0.1 , lens >=4.14 , megaparsec >=9 , memory @@ -253,6 +256,7 @@ library , vector >=0.11.0.0 , vector-algorithms >=0.7 , vector-space >=0.10.4 + , wide-word >= 0.1 , yaml if flag(build-tool) @@ -465,6 +469,7 @@ test-suite hspec GasModelSpec GoldenSpec HistoryServiceSpec + HyperlaneSpec PactContinuationSpec PersistSpec PoseidonSpec diff --git a/src/Crypto/Hash/HyperlaneMessageId.hs b/src/Crypto/Hash/HyperlaneMessageId.hs new file mode 100644 index 000000000..0685a2096 --- /dev/null +++ b/src/Crypto/Hash/HyperlaneMessageId.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +-- | Implementation of the `hyperlane-message-id` pact native. +-- +-- `hyperlane-message-id` takes as input a Pact object representing a +-- 'HyperlaneMessage', and returns a base16-encoded hash of the abi-encoding +-- of the input. +module Crypto.Hash.HyperlaneMessageId (hyperlaneMessageId) where + +import Control.Error.Util (hush) +import Control.Lens ((^?), at, _Just, Prism', _1) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as Base16 +import Data.ByteString.Builder (Builder) +import Data.ByteString.Builder qualified as BB +import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Short qualified as BSS +import Data.Decimal (Decimal) +import Data.Map (Map) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.WideWord.Word256 (Word256(..)) +import Data.Word (Word8, Word32) +import Ethereum.Misc (keccak256, _getKeccak256Hash, _getBytesN) +import Pact.Types.Runtime (Object(..), ObjectMap(..), FieldKey, Name, Literal, _TLiteral, _TObject, _LDecimal, _LInteger, _LString) +import Pact.Types.Term (Term) + +---------------------------------------------- +-- Primitive -- +---------------------------------------------- + +hyperlaneMessageId :: Object Name -> Text +hyperlaneMessageId o = case decodeHyperlaneMessageObject o of + Nothing -> error "Couldn't decode HyperlaneMessage" + Just hm -> getHyperlaneMessageId hm + +---------------------------------------------- +-- Hyperlane Message Encoding -- +---------------------------------------------- + +data HyperlaneMessage = HyperlaneMessage + { hmVersion :: Word8 -- uint8 + , hmNonce :: Word32 -- uint32 + , hmOriginDomain :: Word32 -- uint32 + , hmSender :: ByteString -- 32x uint8 + , hmDestinationDomain :: Word32 -- uint32 + , hmRecipient :: ByteString -- 32x uint8 + , hmTokenMessage :: TokenMessageERC20 -- variable + } + +packHyperlaneMessage :: HyperlaneMessage -> Builder +packHyperlaneMessage (HyperlaneMessage{..}) = + BB.word8 hmVersion + <> BB.word32BE hmNonce + <> BB.word32BE hmOriginDomain + <> BB.byteString (padLeft hmSender) + <> BB.word32BE hmDestinationDomain + <> BB.byteString (padLeft hmRecipient) + <> packTokenMessageERC20 hmTokenMessage + +data TokenMessageERC20 = TokenMessageERC20 + { tmRecipient :: Text -- variable + , tmAmount :: Word256 -- uint256 + , tmChainId :: Maybe Word256 -- uint256 + } + +packTokenMessageERC20 :: TokenMessageERC20 -> Builder +packTokenMessageERC20 t = + word256BE 64 + <> word256BE (tmAmount t) + + <> word256BE recipientSize + <> BB.byteString recipient + where + (recipient, recipientSize) = padRight (Text.encodeUtf8 (tmRecipient t)) + +word256BE :: Word256 -> Builder +word256BE (Word256 a b c d) = + BB.word64BE a <> BB.word64BE b <> BB.word64BE c <> BB.word64BE d + +-- | Pad with zeroes on the left to 32 bytes +-- +-- > padLeft "hello world" +-- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NULhello world" +padLeft :: ByteString -> ByteString +padLeft s = BS.replicate (32 - BS.length s) 0 <> s + +-- | Pad with zeroes on the right, such that the resulting size is a multiple of 32. +-- +-- > padRight "hello world" +-- ("hello world\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL",11) +padRight :: ByteString -> (ByteString, Word256) +padRight s = + let + size = BS.length s + missingZeroes = restSize size + in (s <> BS.replicate missingZeroes 0, fromIntegral size) + +-- | Returns the modular of 32 bytes. +restSize :: Integral a => a -> a +restSize size = (32 - size) `mod` 32 + +---------------------------------------------- +-- Hyperlane Message Hashing -- +---------------------------------------------- + +getHyperlaneMessageId :: HyperlaneMessage -> Text +getHyperlaneMessageId = + encodeHex + . keccak256Hash + . BL.toStrict + . BB.toLazyByteString + . packHyperlaneMessage + +keccak256Hash :: ByteString -> ByteString +keccak256Hash = BSS.fromShort . _getBytesN . _getKeccak256Hash . keccak256 + +encodeHex :: ByteString -> Text +encodeHex b = "0x" <> Text.decodeUtf8 (Base16.encode b) + +decodeHex :: Text -> Maybe ByteString +decodeHex s = do + h <- Text.stripPrefix "0x" s + hush (Base16.decode (Text.encodeUtf8 h)) + +---------------------------------------------- +-- Hyperlane Pact Object Decoding -- +---------------------------------------------- + +decodeHyperlaneMessageObject :: Object Name -> Maybe HyperlaneMessage +decodeHyperlaneMessageObject o = do + let om = _objectMap (_oObject o) + + hmVersion <- fromIntegral @Integer @Word8 <$> grabField om "version" _LInteger + hmNonce <- fromIntegral @Integer @Word32 <$> grabField om "nonce" _LInteger + hmOriginDomain <- fromIntegral @Integer @Word32 <$> grabField om "originDomain" _LInteger + hmSender <- Text.encodeUtf8 <$> grabField om "sender" _LString + hmDestinationDomain <- fromIntegral @Integer @Word32 <$> grabField om "destinationDomain" _LInteger + hmRecipient <- decodeHex =<< grabField om "recipient" _LString + + let tokenObject = om ^? at "tokenMessage" . _Just . _TObject . _1 + hmTokenMessage <- case decodeTokenMessageERC20 =<< tokenObject of + Just t -> pure t + _ -> error "Couldn't encode TokenMessageERC20" + + pure HyperlaneMessage{..} + +decodeTokenMessageERC20 :: Object Name -> Maybe TokenMessageERC20 +decodeTokenMessageERC20 o = do + let om = _objectMap (_oObject o) + tmRecipient <- grabField om "recipient" _LString + tmAmount <- decimalToWord <$> grabField om "amount" _LDecimal + let tmChainId = Nothing + pure $ TokenMessageERC20{..} + +decimalToWord :: Decimal -> Word256 +decimalToWord d = + let ethInWei = 1_000_000_000_000_000_000 -- 1e18 + in round $ d * ethInWei + +grabField :: Map FieldKey (Term Name) -> FieldKey -> Prism' Literal a -> Maybe a +grabField m key p = m ^? at key . _Just . _TLiteral . _1 . p diff --git a/src/Pact/ApiReq.hs b/src/Pact/ApiReq.hs index cd37a1625..de9e74647 100644 --- a/src/Pact/ApiReq.hs +++ b/src/Pact/ApiReq.hs @@ -79,6 +79,7 @@ import Pact.Types.RPC import Pact.Types.Runtime import Pact.Types.SigData import Pact.Types.SPV +import Pact.Types.Verifier import qualified Pact.JSON.Encode as J import Pact.JSON.Legacy.Value import Pact.JSON.Yaml @@ -196,6 +197,7 @@ data ApiReq = ApiReq { _ylCodeFile :: Maybe FilePath, _ylKeyPairs :: Maybe [ApiKeyPair], _ylSigners :: Maybe [ApiSigner], + _ylVerifiers :: Maybe [Verifier ParsedVerifierProof], _ylNonce :: Maybe Text, _ylPublicMeta :: Maybe ApiPublicMeta, _ylNetworkId :: Maybe NetworkId @@ -211,6 +213,7 @@ instance J.Encode ApiReq where , "networkId" J..= _ylNetworkId o , "rollback" J..= _ylRollback o , "signers" J..= fmap J.Array (_ylSigners o) + , "verifiers" J..= fmap J.Array (_ylVerifiers o) , "step" J..= fmap J.Aeson (_ylStep o) , "code" J..= _ylCode o , "pactTxHash" J..= _ylPactTxHash o @@ -228,7 +231,7 @@ instance Arbitrary ApiReq where <*> arbitrary <*> arbitraryValue <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary where arbitraryValue = suchThat arbitrary (/= Just Null) @@ -508,8 +511,8 @@ mkApiReqExec unsignedReq ar@ApiReq{..} fp = do return (code,cdata) pubMeta <- mkPubMeta _ylPublicMeta cmd <- withKeypairsOrSigner unsignedReq ar - (\ks -> mkExec code cdata pubMeta ks _ylNetworkId _ylNonce) - (\ss -> mkUnsignedExec code cdata pubMeta ss _ylNetworkId _ylNonce) + (\ks -> mkExec code cdata pubMeta ks (fromMaybe [] _ylVerifiers) _ylNetworkId _ylNonce) + (\ss -> mkUnsignedExec code cdata pubMeta ss (fromMaybe [] _ylVerifiers) _ylNetworkId _ylNonce) return ((ar,code,cdata,pubMeta), cmd) mkPubMeta :: Maybe ApiPublicMeta -> IO PublicMeta @@ -545,15 +548,18 @@ mkExec -- ^ public metadata -> [(DynKeyPair, [SigCapability])] -- ^ signing keypairs + caplists + -> [Verifier ParsedVerifierProof] + -- ^ verifiers -> Maybe NetworkId -- ^ optional 'NetworkId' -> Maybe Text -- ^ optional nonce -> IO (Command Text) -mkExec code mdata pubMeta kps nid ridm = do +mkExec code mdata pubMeta kps ves nid ridm = do rid <- mkNonce ridm cmd <- mkCommandWithDynKeys kps + ves pubMeta rid nid @@ -571,15 +577,18 @@ mkUnsignedExec -- ^ public metadata -> [Signer] -- ^ payload signers + -> [Verifier ParsedVerifierProof] + -- ^ payload verifiers -> Maybe NetworkId -- ^ optional 'NetworkId' -> Maybe Text -- ^ optional nonce -> IO (Command Text) -mkUnsignedExec code mdata pubMeta kps nid ridm = do +mkUnsignedExec code mdata pubMeta kps ves nid ridm = do rid <- mkNonce ridm cmd <- mkUnsignedCommand kps + ves pubMeta rid nid @@ -613,8 +622,8 @@ mkApiReqCont unsignedReq ar@ApiReq{..} fp = do let pactId = toPactId apiPactId pubMeta <- mkPubMeta _ylPublicMeta cmd <- withKeypairsOrSigner unsignedReq ar - (\ks -> mkCont pactId step rollback cdata pubMeta ks _ylNonce _ylProof _ylNetworkId) - (\ss -> mkUnsignedCont pactId step rollback cdata pubMeta ss _ylNonce _ylProof _ylNetworkId) + (\ks -> mkCont pactId step rollback cdata pubMeta ks (fromMaybe [] _ylVerifiers) _ylNonce _ylProof _ylNetworkId) + (\ss -> mkUnsignedCont pactId step rollback cdata pubMeta ss (fromMaybe [] _ylVerifiers) _ylNonce _ylProof _ylNetworkId) return ((ar,"",cdata,pubMeta), cmd) -- | Construct a Cont request message @@ -632,6 +641,8 @@ mkCont -- ^ command public metadata -> [(DynKeyPair, [SigCapability])] -- ^ signing keypairs + -> [Verifier ParsedVerifierProof] + -- ^ verifiers -> Maybe Text -- ^ optional nonce -> Maybe ContProof @@ -639,10 +650,11 @@ mkCont -> Maybe NetworkId -- ^ optional network id -> IO (Command Text) -mkCont txid step rollback mdata pubMeta kps ridm proof nid = do +mkCont txid step rollback mdata pubMeta kps ves ridm proof nid = do rid <- mkNonce ridm cmd <- mkCommandWithDynKeys kps + ves pubMeta rid nid @@ -665,6 +677,8 @@ mkUnsignedCont -- ^ command public metadata -> [Signer] -- ^ payload signers + -> [Verifier ParsedVerifierProof] + -- ^ verifiers -> Maybe Text -- ^ optional nonce -> Maybe ContProof @@ -672,10 +686,11 @@ mkUnsignedCont -> Maybe NetworkId -- ^ optional network id -> IO (Command Text) -mkUnsignedCont txid step rollback mdata pubMeta kps ridm proof nid = do +mkUnsignedCont txid step rollback mdata pubMeta kps ves ridm proof nid = do rid <- mkNonce ridm cmd <- mkUnsignedCommand kps + ves pubMeta (pack $ show rid) nid diff --git a/src/Pact/Bench.hs b/src/Pact/Bench.hs index e587b40dc..a02bf74ea 100644 --- a/src/Pact/Bench.hs +++ b/src/Pact/Bench.hs @@ -158,6 +158,7 @@ loadBenchModule db = do Nothing pactInitialHash [Signer Nothing pk Nothing []] + [] let ec = ExecutionConfig $ S.fromList [FlagDisablePact44] e <- setupEvalEnv db entity Transactional md (versionedNativesRefStore ec) freeGasEnv permissiveNamespacePolicy noSPVSupport def ec @@ -185,7 +186,7 @@ benchNFIO bname = bench bname . nfIO runPactExec :: Advice -> String -> [Signer] -> Value -> Maybe (ModuleData Ref) -> PactDbEnv e -> ParsedCode -> IO [PactValue] runPactExec pt msg ss cdata benchMod dbEnv pc = do - let md = MsgData (toLegacyJson cdata) Nothing pactInitialHash ss + let md = MsgData (toLegacyJson cdata) Nothing pactInitialHash ss [] ec = ExecutionConfig $ S.fromList [FlagDisablePact44] e <- set eeAdvice pt <$> setupEvalEnv dbEnv entity Transactional md (versionedNativesRefStore ec) prodGasEnv permissiveNamespacePolicy noSPVSupport def ec @@ -197,7 +198,7 @@ runPactExec pt msg ss cdata benchMod dbEnv pc = do execPure :: Advice -> PactDbEnv e -> (String,[Term Name]) -> IO [Term Name] execPure pt dbEnv (n,ts) = do - let md = MsgData (toLegacyJson Null) Nothing pactInitialHash [] + let md = MsgData (toLegacyJson Null) Nothing pactInitialHash [] [] ec = ExecutionConfig $ S.fromList [FlagDisablePact44] env <- set eeAdvice pt <$> setupEvalEnv dbEnv entity Local md (versionedNativesRefStore ec) prodGasEnv permissiveNamespacePolicy noSPVSupport def ec @@ -238,7 +239,7 @@ mkBenchCmd :: [Ed25519KeyPairCaps] -> (String, Text) -> IO (String, Command Byte mkBenchCmd kps (str, t) = do cmd <- mkCommand' kps $ J.encodeStrict - $ Payload payload "nonce" (J.Aeson ()) ss Nothing + $ Payload payload "nonce" (J.Aeson ()) ss Nothing Nothing return (str, cmd) where payload = Exec $ ExecMsg t (toLegacyJson Null) diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs index b440d66af..08ce3271a 100644 --- a/src/Pact/Eval.hs +++ b/src/Pact/Eval.hs @@ -173,7 +173,7 @@ enforceGuard i g = case g of evalError' i $ "Pact guard failed, intended: " <> pretty pid <> ", active: " <> pretty currPid getSizeOfVersion :: Eval e SizeOfVersion -getSizeOfVersion = +getSizeOfVersion = ifExecutionFlagSet' FlagDisablePact45 SizeOfV0 SizeOfV1 {-# INLINABLE getSizeOfVersion #-} @@ -755,7 +755,7 @@ fullyQualifyDefs info mdef defs = do && mn == _mnName (_mName mdef) && isNsMatch -> resolveBareName memo (BareName fn i) where - isNsMatch = fromMaybe True (liftA2 (==) modNs mNs) + isNsMatch = fromMaybe True ((==) <$> modNs <*> mNs) modNs = _mnNamespace (_mName mdef) f -> do dm <- lift (resolveRefFQN f f) -- lookup ref, don't try modules for barenames diff --git a/src/Pact/Gas/Table.hs b/src/Pact/Gas/Table.hs index 0651272ea..0b1fd40e3 100644 --- a/src/Pact/Gas/Table.hs +++ b/src/Pact/Gas/Table.hs @@ -55,6 +55,7 @@ data GasCostConfig = GasCostConfig , _gasCostConfig_formatBytesPerGas :: Gas , _gasCostConfig_poseidonHashHackAChainQuadraticGasFactor :: Gas , _gasCostConfig_poseidonHashHackAChainLinearGasFactor :: Gas + , _gasCostConfig_hyperlaneMessageIdGasPerRecipientOneHundredBytes :: MilliGas } defaultGasConfig :: GasCostConfig @@ -81,6 +82,7 @@ defaultGasConfig = GasCostConfig , _gasCostConfig_formatBytesPerGas = 10 , _gasCostConfig_poseidonHashHackAChainLinearGasFactor = 50 , _gasCostConfig_poseidonHashHackAChainQuadraticGasFactor = 38 + , _gasCostConfig_hyperlaneMessageIdGasPerRecipientOneHundredBytes = MilliGas 47 } defaultGasTable :: Map Text Gas @@ -130,6 +132,7 @@ defaultGasTable = ,("enforce-keyset", 8) ,("enforce-one", 6) ,("enforce-pact-version", 1) + ,("enforce-verifier", 10) ,("enumerate", 1) ,("exp", 5) ,("filter", 3) @@ -235,6 +238,7 @@ defaultGasTable = ,("pairing-check", 1) ,("poseidon-hash-hack-a-chain", 124) + ,("hyperlane-message-id", 2) ] {-# NOINLINE defaultGasTable #-} @@ -332,6 +336,9 @@ tableGasModel gasConfig = gasToMilliGas $ _gasCostConfig_poseidonHashHackAChainQuadraticGasFactor gasConfig * fromIntegral (len * len) + _gasCostConfig_poseidonHashHackAChainLinearGasFactor gasConfig * fromIntegral len + GHyperlaneMessageId len -> + let MilliGas costPerOneHundredBytes = _gasCostConfig_hyperlaneMessageIdGasPerRecipientOneHundredBytes gasConfig + in MilliGas (costPerOneHundredBytes * div (fromIntegral len) 100) in GasModel { gasModelName = "table" diff --git a/src/Pact/GasModel/GasTests.hs b/src/Pact/GasModel/GasTests.hs index 31e9aecb5..6f804b7fd 100644 --- a/src/Pact/GasModel/GasTests.hs +++ b/src/Pact/GasModel/GasTests.hs @@ -23,6 +23,7 @@ import qualified Data.Aeson as A import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -35,6 +36,7 @@ import Pact.Types.Capability import Pact.Types.Lang import Pact.Types.PactValue (PactValue(..)) import Pact.Types.Runtime +import Pact.Types.Verifier (VerifierName(..)) import Pact.JSON.Legacy.Value @@ -223,6 +225,10 @@ allTests = HM.fromList , ("pairing-check", pairingCheckTests) , ("poseidon-hash-hack-a-chain", poseidonHashTests) + -- SPI/Hyperlane + , ("hyperlane-message-id", hyperlaneMessageIdTests) + , ("enforce-verifier", enforceVerifierTests) + -- Non-native concepts to benchmark , ("use", useTests) , ("module", moduleTests) @@ -2009,3 +2015,32 @@ poseidonHashTests = defGasUnitTest $ PactExpression poseidonHashExprText Nothing (poseidon-hash-hack-a-chain 1 2) (poseidon-hash-hack-a-chain 999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999 88888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888888) |] + +enforceVerifierTests :: NativeDefName -> GasUnitTests +enforceVerifierTests = createGasUnitTests signEnvWithKeySet signEnvWithKeySet [PactExpression enforceVerifierExprText Nothing] + where + verifMap :: M.Map VerifierName (S.Set SigCapability) + verifMap = M.fromList + [ (VerifierName "HYPERLANE", S.fromList [SigCapability (QualifiedName "m" "GOOD" def) []]) + ] + + signEnvWithKeySet = setEnv (set eeMsgVerifiers verifMap) + + enforceVerifierExprText = [text| + (module m GOV + (defcap GOV () true) + + (defcap GOOD () (enforce-verifier 'HYPERLANE)) + + (defun good () (with-capability (GOOD) 1)) + ) + (good) + |] + +hyperlaneMessageIdTests :: NativeDefName -> GasUnitTests +hyperlaneMessageIdTests = defGasUnitTest $ PactExpression hyperlaneMessageIdExprText Nothing + where + hyperlaneMessageIdExprText = [text| + (hyperlane-message-id {"destinationDomain": 1,"nonce": 325,"originDomain": 626,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F","sender": "0x6b622d746f6b656e2d726f75746572","tokenMessage": {"amount": 10000000000000000000.0,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F"},"version": 1}) + (hyperlane-message-id {"destinationDomain": 1,"nonce": 325,"originDomain": 626,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F","sender": "0x6b622d746f6b656e2d726f75746572","tokenMessage": {"amount": 10000000000000000000.0,"recipient": "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"},"version": 1}) + |] diff --git a/src/Pact/Interpreter.hs b/src/Pact/Interpreter.hs index 05f3acec4..aa87c951b 100644 --- a/src/Pact/Interpreter.hs +++ b/src/Pact/Interpreter.hs @@ -77,6 +77,7 @@ import Pact.Types.Pretty import Pact.Types.RPC import Pact.Types.Runtime import Pact.Types.SPV +import Pact.Types.Verifier import Pact.JSON.Legacy.Value @@ -91,12 +92,13 @@ data MsgData = MsgData { mdData :: !LegacyValue, mdStep :: !(Maybe PactStep), mdHash :: !Hash, - mdSigners :: [Signer] + mdSigners :: [Signer], + mdVerifiers :: [Verifier ()] } initMsgData :: Hash -> MsgData -initMsgData h = MsgData (toLegacyJson Null) def h def +initMsgData h = MsgData (toLegacyJson Null) def h def def -- | Describes either a ContMsg or ExecMsg. -- ContMsg is represented as a 'Maybe PactExec' @@ -192,6 +194,7 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do pure EvalEnv { _eeRefStore = refStore , _eeMsgSigs = mkMsgSigs $ mdSigners msgData + , _eeMsgVerifiers = mkMsgVerifiers $ mdVerifiers msgData , _eeMsgBody = mdData msgData , _eeMode = mode , _eeEntity = ent @@ -216,6 +219,9 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do toPair Signer{..} = (pk,S.fromList _siCapList) where pk = PublicKeyText $ fromMaybe _siPubKey _siAddress + mkMsgVerifiers vs = M.fromListWith S.union $ map toPair vs + where + toPair Verifier{..} = (_verifierName, S.fromList _verifierCaps) disablePactNatives :: [Text] -> ExecutionFlag -> ExecutionConfig -> Endo RefStore @@ -245,6 +251,9 @@ disablePact47Natives = disablePactNatives pact47Natives FlagDisablePact47 disablePact410Natives :: ExecutionConfig -> Endo RefStore disablePact410Natives = disablePactNatives pact410Natives FlagDisablePact410 +disableVerifierNatives :: ExecutionConfig -> Endo RefStore +disableVerifierNatives = disablePactNatives verifierNatives FlagDisableVerifiers + pact40Natives :: [Text] pact40Natives = ["enumerate" , "distinct" , "emit-event" , "concat" , "str-to-list"] @@ -266,6 +275,9 @@ pact47Natives = ["dec"] pact410Natives :: [Text] pact410Natives = ["poseidon-hash-hack-a-chain"] +verifierNatives :: [Text] +verifierNatives = ["enforce-verifier", "hyperlane-message-id"] + initRefStore :: RefStore initRefStore = RefStore nativeDefs @@ -279,7 +291,8 @@ versionedNativesRefStore ec = versionNatives initRefStore , disablePact431Natives ec , disablePact46Natives ec , disablePact47Natives ec - , disablePact410Natives ec ] + , disablePact410Natives ec + , disableVerifierNatives ec ] mkSQLiteEnv :: Logger -> Bool -> PSL.SQLiteConfig -> Loggers -> IO (PactDbEnv (DbEnv PSL.SQLite)) mkSQLiteEnv initLog deleteOldFile c loggers = do diff --git a/src/Pact/Native.hs b/src/Pact/Native.hs index b5cbf030a..7208a4840 100644 --- a/src/Pact/Native.hs +++ b/src/Pact/Native.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-} -- | @@ -107,6 +108,7 @@ import Pact.Types.Runtime import Pact.Types.Version import Pact.Types.Namespace import Crypto.Hash.PoseidonNative (poseidon) +import Crypto.Hash.HyperlaneMessageId (hyperlaneMessageId) import qualified Pact.JSON.Encode as J @@ -124,6 +126,7 @@ natives = , guardDefs , zkDefs , poseidonHackAChainDefs + , hyperlaneDefs ] @@ -1239,21 +1242,23 @@ enforceVersion i as = do pactVersion' <- if cond then pure compatVersion else checkNonLocalAllowed i $> pactVersion case as of - [TLitString minVersion] -> doMin minVersion pactVersion' >> return (toTerm True) + [TLitString minVersion] -> doMin minVersion pactVersion' $> toTerm True [TLitString minVersion,TLitString maxVersion] -> - doMin minVersion pactVersion' >> doMax maxVersion pactVersion' >> return (toTerm True) + doMin minVersion pactVersion' >> doMax maxVersion pactVersion' $> toTerm True _ -> argsError i as where compatVersion :: Text compatVersion = "4.2.1" doMin = doMatch "minimum" (>) (<) doMax = doMatch "maximum" (<) (>) - doMatch msg failCmp succCmp fullV pactVersion' = + doMatch msg failCmp succCmp fullV pactVersion' = do foldM_ matchPart False $ zip (T.splitOn "." pactVersion') (T.splitOn "." fullV) where - parseNum orgV s = case AP.parseOnly (AP.many1 AP.digit) s of + parseNum :: Text -> Text -> Eval e Integer + parseNum orgV s = case AP.parseOnly AP.decimal s of Left _ -> evalError' i $ "Invalid version component: " <> pretty (orgV,s) Right v -> return v + matchPart True _ = return True matchPart _ (pv,mv) = do pv' <- parseNum pactVersion' pv @@ -1570,3 +1575,37 @@ poseidonHackAChainDef = defGasRNative = computeGas' i (GPoseidonHashHackAChain $ length as) $ return $ toTerm $ poseidon intArgs | otherwise = argsError i as + +hyperlaneDefs :: NativeModule +hyperlaneDefs = ("Hyperlane",) + [ hyperlaneMessageIdDef + ] + +hyperlaneMessageIdDef :: NativeDef +hyperlaneMessageIdDef = defGasRNative + "hyperlane-message-id" + hyperlaneMessageId' + (funType tTyString [("x", tTyObjectAny)]) + [ + "(hyperlane-message-id {\"destinationDomain\": 1,\"nonce\": 325,\"originDomain\": 626,\"recipient\": \"0x71C7656EC7ab88b098defB751B7401B5f6d8976F\",\"sender\": \"0x6b622d746f6b656e2d726f75746572\",\"tokenMessage\": {\"amount\": 10000000000000000000.0,\"recipient\": \"0x71C7656EC7ab88b098defB751B7401B5f6d8976F\"},\"version\": 1})" + ] + "Get the Message Id of a Hyperlane Message object." + where + hyperlaneMessageId' :: RNativeFun e + hyperlaneMessageId' i args = case args of + [TObject o _] -> + computeGas' i (GHyperlaneMessageId (BS.length (getTokenRecipient o))) + $ return $ toTerm $ hyperlaneMessageId o + _ -> argsError i args + + getTokenRecipient :: Object n -> BS.ByteString + getTokenRecipient o = + let mRecipient = do + let om = _objectMap (_oObject o) + tokenObject <- om ^? at "tokenMessage" . _Just . _TObject . _1 + let tm = _objectMap (_oObject tokenObject) + tm ^? at "recipient" . _Just . _TLiteral . _1 . _LString + in + case mRecipient of + Nothing -> error "couldn't decode token recipient" + Just t -> T.encodeUtf8 t diff --git a/src/Pact/Native/Capabilities.hs b/src/Pact/Native/Capabilities.hs index 15b58b3cb..f9e9373af 100644 --- a/src/Pact/Native/Capabilities.hs +++ b/src/Pact/Native/Capabilities.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Pact.Native.Capabilities @@ -22,6 +23,7 @@ module Pact.Native.Capabilities import Control.Lens import Control.Monad import Data.Default +import qualified Data.Map.Strict as Map import Data.Maybe (isJust) import qualified Data.Set as S @@ -32,6 +34,7 @@ import Pact.Types.Capability import Pact.Types.PactValue import Pact.Types.Pretty import Pact.Types.Runtime +import Pact.Types.Verifier capDefs :: NativeModule capDefs = @@ -42,6 +45,7 @@ capDefs = , requireCapability , composeCapability , emitEventDef + , enforceVerifierDef ]) tvA :: Type n @@ -69,8 +73,13 @@ withCapability = enforceNotWithinDefcap i "with-capability" + (cap,d,prep) <- appToCap (_tApp c) + evalUserCapabilitiesBeingEvaluated %= S.insert cap + -- evaluate in-module cap - acquireResult <- evalCap i CapCallStack True (_tApp c) + acquireResult <- evalCap (getInfo i) CapCallStack True (cap,d,prep,getInfo c) + + evalUserCapabilitiesBeingEvaluated %= S.delete cap -- execute scoped code r <- reduceBody body @@ -123,13 +132,16 @@ installCapability = -- | Given cap app, enforce in-module call, eval args to form capability, -- and attempt to acquire. Return capability if newly-granted. When -- 'inModule' is 'True', natives can only be invoked within module code. -evalCap :: HasInfo i => i -> CapScope -> Bool -> App (Term Ref) -> Eval e CapEvalResult -evalCap i scope inModule a@App{..} = do - (cap,d,prep) <- appToCap a - when inModule $ guardForModuleCall _appInfo (_dModule d) $ return () +evalCap + :: HasInfo i + => i -> CapScope -> Bool + -> (UserCapability, Def Ref, ([Term Name], FunType (Term Name)), i) + -> Eval e CapEvalResult +evalCap i scope inModule (cap,d,prep,getInfo -> capInfo) = do + when inModule $ guardForModuleCall capInfo (_dModule d) $ return () evalUserCapability i capFuns scope cap d $ do - computeUserAppGas d _appInfo - void $ evalUserAppBody d prep _appInfo reduceBody + computeUserAppGas d capInfo + void $ evalUserAppBody d prep capInfo reduceBody -- | Continuation to tie the knot with Pact.Eval (ie, 'apply') and also because the capDef is @@ -157,15 +169,12 @@ capFuns :: (ApplyMgrFun e,InstallMgd e) capFuns = (applyMgrFun,installSigCap) installSigCap :: InstallMgd e -installSigCap SigCapability{..} cdef = do - r <- evalCap cdef CapManaged True $ mkApp cdef (map fromPactValue _scArgs) +installSigCap cap@SigCapability{..} cdef = do + ty <- traverse reduce (_dFunType cdef) + r <- evalCap (getInfo cdef) CapManaged True (cap,cdef,(fromPactValue <$> _scArgs,ty),getInfo cdef) case r of NewlyInstalled mc -> return mc _ -> evalError' cdef "Unexpected result from managed sig cap install" - where - mkApp d@Def{} as = - App (TVar (Ref (TDef d (getInfo d))) (getInfo d)) - (map liftTerm as) (getInfo d) enforceNotWithinDefcap :: HasInfo i => i -> Doc -> Eval e () @@ -207,7 +216,10 @@ composeCapability = -- enforce in defcap defcapInStack (Just 1) >>= \p -> unless p $ evalError' i "compose-capability valid only within defcap body" -- evalCap as composed, which will install onto head of pending cap - void $ evalCap i CapComposed True app + (cap,d,prep) <- appToCap app + evalUserCapabilitiesBeingEvaluated %= S.insert cap + void $ evalCap (getInfo i) CapComposed True (cap,d,prep,getInfo app) + evalUserCapabilitiesBeingEvaluated %= S.delete cap return $ toTerm True composeCapability' i as = argsError' i as @@ -253,3 +265,27 @@ emitEventDef = DefcapManaged {} -> return () DefcapEvent -> return () _ -> evalError' i $ "emit-event: must be managed or event defcap" + +enforceVerifierDef :: NativeDef +enforceVerifierDef = defRNative + "enforce-verifier" + enforceVerifier + (funType tTyBool [("verifiername", tTyString)]) + [ LitExample $ "(enforce-verifier 'COOLZK)" + ] + "Enforce that a verifier is in scope." + where + enforceVerifier :: RNativeFun e + enforceVerifier i as = case as of + [TLitString verName] -> do + views eeMsgVerifiers (Map.lookup (VerifierName verName)) >>= \case + Just verCaps -> do + inCap <- defcapInStack Nothing + unless inCap $ + failTx (getInfo i) $ "enforce-verifier must be run in a capability" + verifierInScope <- anyCapabilityBeingEvaluated verCaps + if verifierInScope then return (toTerm True) + else failTx (getInfo i) $ "Verifier failure " <> pretty verName <> ": not in scope" + Nothing -> + failTx (getInfo i) $ "Verifier failure " <> pretty verName <> ": not in transaction" + _ -> argsError i as diff --git a/src/Pact/Repl.hs b/src/Pact/Repl.hs index 6ca0f34db..bc9f2ed18 100644 --- a/src/Pact/Repl.hs +++ b/src/Pact/Repl.hs @@ -137,6 +137,7 @@ initEvalEnv ls = do return $ EvalEnv { _eeRefStore = RefStore nativeDefs , _eeMsgSigs = mempty + , _eeMsgVerifiers = mempty , _eeMsgBody = toLegacyJson (A.Object mempty) , _eeMode = Transactional , _eeEntity = Nothing diff --git a/src/Pact/Repl/Lib.hs b/src/Pact/Repl/Lib.hs index d8cf87c8a..e09b5e893 100644 --- a/src/Pact/Repl/Lib.hs +++ b/src/Pact/Repl/Lib.hs @@ -69,8 +69,9 @@ import Pact.Types.Pretty import Pact.Repl.Types import Pact.Native.Capabilities (evalCap) import Pact.Gas.Table -import Pact.Types.PactValue import Pact.Types.Capability +import Pact.Types.PactValue +import Pact.Types.Verifier import Pact.Interpreter import Pact.Runtime.Utils import Pact.JSON.Legacy.Value @@ -115,7 +116,11 @@ replDefs = ("Repl", "{'key: \"admin-key\", 'caps: []}"] ("Set transaction signature keys and capabilities. SIGS is a list of objects with \"key\" " <> "specifying the signer key, and \"caps\" specifying a list of associated capabilities.") - + ,defZNative "env-verifiers" envVerifiers (funType tTyString [("verifiers",TyList (tTyObject TyAny))]) + [LitExample $ "(env-verifiers [({'name: \"COOLZK\", 'caps: [(accounts.USER_GUARD \"my-account\")]}, " <> + "{'name: \"HYPERCHAIN-BRIDGE\", 'caps: [(bridge.MINT \"mycoin\" 20)]}])"] + ("Set transaction verifier names and capabilities. VERIFIERS is a list of objects with \"name\" " <> + "specifying the verifier name, and \"caps\" specifying a list of associated capabilities.") ,defZRNative "env-data" setmsg (funType tTyString [("json",json)]) ["(env-data { \"keyset\": { \"keys\": [\"my-key\" \"admin-key\"], \"pred\": \"keys-any\" } })"] "Set transaction JSON data, either as encoded string, or as pact types coerced to JSON." @@ -360,6 +365,25 @@ setsigs' _ [TList ts _ _] = do return $ tStr "Setting transaction signatures/caps" setsigs' i as = argsError' i as +envVerifiers :: ZNativeFun LibState +envVerifiers _ [TList ts _ _] = do + vers <- forM ts $ \t -> case t of + TObject (Object (ObjectMap om) _ _ _) _ -> do + case (M.lookup "name" om, M.lookup "caps" om) of + (Just k'', Just (TList clist _ _)) -> do + reduce k'' >>= \k' -> case k' of + TLitString k -> do + caps <- forM clist $ \cap -> case cap of + TApp a _ -> view _1 <$> appToCap a + o -> evalError' o $ "Expected capability invocation" + return (VerifierName k, S.fromList (V.toList caps)) + _ -> evalError' k' "Expected string value" + _ -> evalError' t "Expected object with 'name': string, 'caps': [capability]" + _ -> evalError' t $ "Expected object" + setenv eeMsgVerifiers $ M.fromList $ V.toList vers + return $ tStr "Setting transaction verifiers/caps" +envVerifiers i as = argsError' i as + setmsg :: RNativeFun LibState setmsg i as = case as of @@ -738,9 +762,9 @@ setGasModel _ as = do -- using 'evalCap False'. testCapability :: ZNativeFun ReplState testCapability i [ (TApp app _) ] = do - (_,d,_) <- appToCap app + (cap,d,prep) <- appToCap app let scope = maybe CapCallStack (const CapManaged) (_dDefMeta d) - r <- evalCap i scope False $ app + r <- evalCap (getInfo i) scope False (cap,d,prep,getInfo app) return . tStr $ case r of AlreadyAcquired -> "Capability already acquired" NewlyAcquired -> "Capability acquired" diff --git a/src/Pact/Runtime/Capabilities.hs b/src/Pact/Runtime/Capabilities.hs index 9a7e5115a..81325b490 100644 --- a/src/Pact/Runtime/Capabilities.hs +++ b/src/Pact/Runtime/Capabilities.hs @@ -24,6 +24,7 @@ module Pact.Runtime.Capabilities ,acquireModuleAdminCapability ,popCapStack ,revokeAllCapabilities + ,anyCapabilityBeingEvaluated ,capabilityAcquired ,ApplyMgrFun ,InstallMgd @@ -52,6 +53,12 @@ type ApplyMgrFun e = Def Ref -> PactValue -> PactValue -> Eval e PactValue type InstallMgd e = UserCapability -> Def Ref -> Eval e (ManagedCapability UserCapability) +-- | Check if any of these capabilities are being evaluated. +anyCapabilityBeingEvaluated :: S.Set UserCapability -> Eval e Bool +anyCapabilityBeingEvaluated caps = do + capsBeingEvaluated <- use evalUserCapabilitiesBeingEvaluated + return $! any (`S.member` caps) capsBeingEvaluated + -- | Check for acquired/stack (or composed therein) capability. capabilityAcquired :: UserCapability -> Eval e Bool capabilityAcquired cap = elem cap <$> getAllStackCaps @@ -181,7 +188,7 @@ defCapMetaParts cap argName cdef = case findArg argName of findArg an = findIndex ((==) an . _aName) $ _ftArgs (_dFunType cdef) -- Check managed state, if any, to approve acquisition. --- Handles lazy installation of sig + auto caps, as a fallback +-- Handles lazy installation of sig + verifier + auto caps, as a fallback -- case if no matching installed managed caps are found. -- Once found/matched, compute installed logic to approve acquisition. -- Upon success return composed caps that were assembled during install @@ -204,7 +211,7 @@ checkManaged i (applyF,installF) cap@SigCapability{} cdef = case _dDefMeta cdef -- go: main loop over installed managed caps set -- empty case: attempt lazy install and test go dcm [] = do - checkSigs dcm >>= \r -> case r of + checkUserCaps dcm >>= \r -> case r of Nothing -> die Just mc -> testMC mc die -- test installed from set @@ -241,22 +248,23 @@ checkManaged i (applyF,installF) cap@SigCapability{} cdef = case _dDefMeta cdef Just (argName,_) -> view _2 <$> defCapMetaParts c argName cdef getStatic DefcapEvent c = return c - -- check sig and autonomous caps for match - -- to install. - checkSigs dcm = case getStatic dcm cap of + -- check sig, verifier, and autonomous caps for match to install. + checkUserCaps dcm = case getStatic dcm cap of Left e -> evalError' cdef e Right capStatic -> do autos <- use $ evalCapabilities . capAutonomous - sigCaps <- (S.union autos . S.unions) <$> view eeMsgSigs - foldM (matchSig dcm capStatic) Nothing sigCaps + sigCaps <- S.unions <$> view eeMsgSigs + verifierCaps <- S.unions <$> view eeMsgVerifiers + let msgCaps = S.unions [autos, sigCaps, verifierCaps] + foldM (matchUserCap dcm capStatic) Nothing msgCaps - matchSig _ _ r@Just{} _ = return r - matchSig dcm capStatic Nothing sigCap = case getStatic dcm sigCap of + matchUserCap _ _ r@Just{} _ = return r + matchUserCap dcm capStatic Nothing userCap = case getStatic dcm userCap of Left _ -> return Nothing - Right sigStatic | sigStatic == capStatic -> Just <$> doMgdInstall sigCap + Right sigStatic | sigStatic == capStatic -> Just <$> doMgdInstall userCap | otherwise -> return Nothing - doMgdInstall sigCap = installF sigCap cdef + doMgdInstall userCap = installF userCap cdef revokeAllCapabilities :: Eval e () diff --git a/src/Pact/Server/PactService.hs b/src/Pact/Server/PactService.hs index e0f683129..b05aef6c2 100644 --- a/src/Pact/Server/PactService.hs +++ b/src/Pact/Server/PactService.hs @@ -152,7 +152,7 @@ applyExec rk hsh signers (ExecMsg parsedCode edata) = do when (null (_pcExps parsedCode)) $ throwCmdEx "No expressions found" evalEnv <- liftIO $ setupEvalEnv _ceDbEnv _ceEntity _ceMode - (MsgData edata Nothing (toUntypedHash hsh) signers) + (MsgData edata Nothing (toUntypedHash hsh) signers []) initRefStore _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalExec defaultInterpreter evalEnv parsedCode @@ -165,7 +165,7 @@ applyContinuation rk hsh signers cm = do CommandEnv{..} <- ask -- Setup environment and get result evalEnv <- liftIO $ setupEvalEnv _ceDbEnv _ceEntity _ceMode - (MsgData (toLegacyJson (_cmData cm)) Nothing (toUntypedHash hsh) signers) (versionedNativesRefStore _ceExecutionConfig) + (MsgData (toLegacyJson (_cmData cm)) Nothing (toUntypedHash hsh) signers []) (versionedNativesRefStore _ceExecutionConfig) _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalContinuation defaultInterpreter evalEnv cm return $ resultSuccess _erTxId rk _erGas (last _erOutput) _erExec _erLogs _erEvents diff --git a/src/Pact/Server/Server.hs b/src/Pact/Server/Server.hs index 83d348c5c..c278394f3 100644 --- a/src/Pact/Server/Server.hs +++ b/src/Pact/Server/Server.hs @@ -84,13 +84,14 @@ usage = unlines [ "Config file is YAML format with the following properties:" , "port - HTTP server port" , "persistDir - Directory for database files." - , " If ommitted, runs in-memory only." + , " If omitted, runs in-memory only." , "logDir - Directory for HTTP logs" , "pragmas - SQLite pragmas to use with persistence DBs" , "entity - Entity name for simulating privacy, defaults to \"entity\"" , "gasLimit - Gas limit for each transaction, defaults to 0" , "gasRate - Gas price per action, defaults to 0" - , "flags - Pact runtime execution flags" + , "execConfig - Pact runtime execution flags" + , "verbose - Output additional information" , "\n" ] diff --git a/src/Pact/Typechecker.hs b/src/Pact/Typechecker.hs index 2a56d059f..db26923a8 100644 --- a/src/Pact/Typechecker.hs +++ b/src/Pact/Typechecker.hs @@ -839,20 +839,22 @@ withScopeBodyToFun fnname modname funTy body deftype info = do return $ FDefun info modname fnname deftype funType args tcs funId assocStepYieldReturns :: TopLevel Node -> [AST Node] -> TC () -assocStepYieldReturns (TopFun (FDefun _ _ _ Defpact _ _ _ _) _) steps = +assocStepYieldReturns (TopFun (FDefun _ _ _ Defpact _ _ _ rty) _) steps = void $ toStepYRs >>= foldM go (Nothing,0::Int) where lastStep = pred $ length steps toStepYRs = forM steps $ \step -> case step of - Step{..} -> case (_aYieldResume, _aRollback) of - - -- check that a cross-chain yield and rollback do not occur - -- in the same step, otherwise build the tuple - (Just y, Just{}) -> - if _yrCrossChain y - then die'' step "Illegal rollback with yield" - else return (_aNode, _aYieldResume) - _ -> return (_aNode, _aYieldResume) + Step{..} -> do + -- Associate the DefPact return type with each step + assocNode rty _aNode + case (_aYieldResume, _aRollback) of + -- check that a cross-chain yield and rollback do not occur + -- in the same step, otherwise build the tuple + (Just y, Just{}) -> + if _yrCrossChain y + then die'' step "Illegal rollback with yield" + else return (_aNode, _aYieldResume) + _ -> return (_aNode, _aYieldResume) _ -> die'' step "Non-step in defpact" yrMay l yr = preview (_Just . l . _Just) yr go :: (Maybe (YieldResume Node),Int) -> (Node, Maybe (YieldResume Node)) -> TC (Maybe (YieldResume Node),Int) @@ -879,7 +881,6 @@ assocStepYieldReturns (TopFun (FDefun _ _ _ Defpact _ _ _ _) _) steps = b' <- lookupSchemaTy b debug $ "assocYRSchemas: " ++ showPretty ((a,a'),(b,b')) assocParams (_aId a) a' b' - assocStepYieldReturns _ _ = return () diff --git a/src/Pact/Types/Command.hs b/src/Pact/Types/Command.hs index b71560bcf..92d435908 100644 --- a/src/Pact/Types/Command.hs +++ b/src/Pact/Types/Command.hs @@ -45,7 +45,7 @@ module Pact.Types.Command , PPKScheme(..) , Ed25519KeyPairCaps , ProcessedCommand(..),_ProcSucc,_ProcFail - , Payload(..),pMeta,pNonce,pPayload,pSigners,pNetworkId + , Payload(..),pMeta,pNonce,pPayload,pSigners,pVerifiers,pNetworkId , ParsedCode(..),pcCode,pcExps , Signer(..),siScheme, siPubKey, siAddress, siCapList , UserSig(..) @@ -91,6 +91,7 @@ import Pact.Types.Orphans () import Pact.Types.PactValue (PactValue(..)) import Pact.Types.RPC import Pact.Types.Runtime +import Pact.Types.Verifier import Pact.JSON.Legacy.Value import qualified Pact.JSON.Encode as J @@ -147,15 +148,16 @@ mkCommand :: J.Encode c => J.Encode m => [(Ed25519KeyPair, [SigCapability])] + -> [Verifier ParsedVerifierProof] -> m -> Text -> Maybe NetworkId -> PactRPC c -> IO (Command ByteString) -mkCommand creds meta nonce nid rpc = mkCommand' creds encodedPayload +mkCommand creds vers meta nonce nid rpc = mkCommand' creds encodedPayload where encodedPayload = J.encodeStrict $ toLegacyJsonViaEncode payload - payload = Payload rpc nonce meta (keyPairsToSigners creds) nid + payload = Payload rpc nonce meta (keyPairsToSigners creds) (vers <$ guard (not (null vers))) nid data WebAuthnPubKeyPrefixed = WebAuthnPubKeyPrefixed @@ -169,16 +171,17 @@ data DynKeyPair mkCommandWithDynKeys :: J.Encode c => J.Encode m - => [(DynKeyPair, [SigCapability])] + => [(DynKeyPair, [UserCapability])] + -> [Verifier ParsedVerifierProof] -> m -> Text -> Maybe NetworkId -> PactRPC c -> IO (Command ByteString) -mkCommandWithDynKeys creds meta nonce nid rpc = mkCommandWithDynKeys' creds encodedPayload +mkCommandWithDynKeys creds vers meta nonce nid rpc = mkCommandWithDynKeys' creds encodedPayload where encodedPayload = J.encodeStrict $ toLegacyJsonViaEncode payload - payload = Payload rpc nonce meta (map credToSigner creds) nid + payload = Payload rpc nonce meta (map credToSigner creds) (vers <$ guard (not (null vers))) nid credToSigner cred = case cred of (DynEd25519KeyPair (pubEd25519, _), caps) -> @@ -200,7 +203,7 @@ mkCommandWithDynKeys creds meta nonce nid rpc = mkCommandWithDynKeys' creds enco , _siCapList = caps } -keyPairToSigner :: Ed25519KeyPair -> [SigCapability] -> Signer +keyPairToSigner :: Ed25519KeyPair -> [UserCapability] -> Signer keyPairToSigner cred caps = Signer scheme pub addr caps where scheme = Nothing @@ -242,14 +245,15 @@ mkUnsignedCommand :: J.Encode m => J.Encode c => [Signer] + -> [Verifier ParsedVerifierProof] -> m -> Text -> Maybe NetworkId -> PactRPC c -> IO (Command ByteString) -mkUnsignedCommand signers meta nonce nid rpc = mkCommand' [] encodedPayload +mkUnsignedCommand signers vers meta nonce nid rpc = mkCommand' [] encodedPayload where encodedPayload = J.encodeStrict payload - payload = Payload rpc nonce meta signers nid + payload = Payload rpc nonce meta signers (vers <$ guard (not (null vers))) nid signHash :: TypedHash h -> Ed25519KeyPair -> Text signHash hsh (pub,priv) = @@ -281,7 +285,7 @@ hasInvalidSigs hsh sigs signers | otherwise = verifyUserSigs hsh (zip sigs signers) verifyUserSigs :: PactHash -> [(UserSig, Signer)] -> Maybe String -verifyUserSigs hsh sigsAndSigners +verifyUserSigs hsh sigsAndSigners | null failedSigs = Nothing | otherwise = formatIssues where @@ -365,6 +369,7 @@ data Payload m c = Payload , _pNonce :: !Text , _pMeta :: !m , _pSigners :: ![Signer] + , _pVerifiers :: !(Maybe [Verifier ParsedVerifierProof]) , _pNetworkId :: !(Maybe NetworkId) } deriving (Show, Eq, Generic, Functor, Foldable, Traversable) instance (NFData a,NFData m) => NFData (Payload m a) @@ -374,6 +379,7 @@ instance (J.Encode a, J.Encode m) => J.Encode (Payload m a) where [ "networkId" J..= _pNetworkId o , "payload" J..= _pPayload o , "signers" J..= J.Array (_pSigners o) + , "verifiers" J..?= fmap J.Array (_pVerifiers o) , "meta" J..= _pMeta o , "nonce" J..= _pNonce o ] @@ -388,6 +394,7 @@ instance (Arbitrary m, Arbitrary c) => Arbitrary (Payload m c) where <*> arbitrary <*> scale (min 10) arbitrary <*> arbitrary + <*> arbitrary newtype PactResult = PactResult { _pactResult :: Either PactError PactValue diff --git a/src/Pact/Types/Gas.hs b/src/Pact/Types/Gas.hs index 406e08383..1aeb8e48a 100644 --- a/src/Pact/Types/Gas.hs +++ b/src/Pact/Types/Gas.hs @@ -182,6 +182,10 @@ data GasArgs -- ^ Cost of formatting with the given format string and args | GPoseidonHashHackAChain !Int -- ^ Cost of the hack-a-chain poseidon hash on this given number of inputs + | GHyperlaneMessageId !Int + -- ^ Cost of the hyperlane-message-id on this size (in bytes) of the + -- hyperlane TokenMessage Recipient, which is the only variable-length + -- part of a HyperlaneMessage data IntOpThreshold = Pact43IntThreshold @@ -250,6 +254,7 @@ instance Pretty GasArgs where GReverse len -> "GReverse:" <> pretty len GFormatValues s args -> "GFormatValues:" <> pretty s <> pretty (V.toList args) GPoseidonHashHackAChain len -> "GPoseidonHashHackAChain:" <> pretty len + GHyperlaneMessageId len -> "GHyperlaneMessageId:" <> pretty len newtype GasLimit = GasLimit ParsedInteger deriving (Eq,Ord,Generic) diff --git a/src/Pact/Types/Purity.hs b/src/Pact/Types/Purity.hs index fa4ca887a..bd6c206a7 100644 --- a/src/Pact/Types/Purity.hs +++ b/src/Pact/Types/Purity.hs @@ -72,6 +72,7 @@ mkPureEnv holder purity readRowImpl env@EvalEnv{..} = do return $ EvalEnv _eeRefStore _eeMsgSigs + _eeMsgVerifiers _eeMsgBody _eeMode _eeEntity diff --git a/src/Pact/Types/Runtime.hs b/src/Pact/Types/Runtime.hs index 30f86b57d..7caa70093 100644 --- a/src/Pact/Types/Runtime.hs +++ b/src/Pact/Types/Runtime.hs @@ -30,14 +30,14 @@ module Pact.Types.Runtime PactId(..), PactEvent(..), eventName, eventParams, eventModule, eventModuleHash, RefStore(..),rsNatives, - EvalEnv(..),eeRefStore,eeMsgSigs,eeMsgBody,eeMode,eeEntity,eePactStep,eePactDbVar,eeInRepl, + EvalEnv(..),eeRefStore,eeMsgSigs,eeMsgVerifiers,eeMsgBody,eeMode,eeEntity,eePactStep,eePactDbVar,eeInRepl, eePactDb,eePurity,eeHash,eeGas, eeGasEnv,eeNamespacePolicy,eeSPVSupport,eePublicData,eeExecutionConfig, eeAdvice, eeWarnings, toPactId, Purity(..), RefState(..),rsLoaded,rsLoadedModules,rsNamespace,rsQualifiedDeps, EvalState(..),evalRefs,evalCallStack,evalPactExec, - evalCapabilities,evalLogGas,evalEvents, + evalCapabilities,evalLogGas,evalEvents,evalUserCapabilitiesBeingEvaluated, Eval(..),runEval,runEval',catchesPactError, call,method, readRow,writeRow,keys,txids,createUserTable,getUserTableInfo,beginTx,commitTx,rollbackTx,getTxLog, @@ -98,6 +98,7 @@ import Pact.Types.Pretty import Pact.Types.RowData import Pact.Types.SPV import Pact.Types.Util +import Pact.Types.Verifier import Pact.Types.Namespace import Pact.JSON.Legacy.Value (LegacyValue(..)) @@ -204,6 +205,8 @@ data ExecutionFlag | FlagDisablePact410 -- | Disable Pact 4.11 Features | FlagDisablePact411 + -- | Disable verifiers + | FlagDisableVerifiers deriving (Eq,Ord,Show,Enum,Bounded) -- | Flag string representation @@ -257,6 +260,8 @@ data EvalEnv e = EvalEnv { _eeRefStore :: !RefStore -- | Verified keys from message. , _eeMsgSigs :: !(M.Map PublicKeyText (S.Set UserCapability)) + -- | Verifiers other than signatures. + , _eeMsgVerifiers :: !(M.Map VerifierName (S.Set UserCapability)) -- | JSON body accompanying message. , _eeMsgBody :: !LegacyValue -- | Execution mode @@ -351,8 +356,10 @@ data EvalState = EvalState { , _evalCallStack :: ![StackFrame] -- | Pact execution trace, if any , _evalPactExec :: !(Maybe PactExec) - -- | Capability list + -- | Granted capability list , _evalCapabilities :: !Capabilities + -- | Capabilities being evaluated + , _evalUserCapabilitiesBeingEvaluated :: !(Set UserCapability) -- | Tracks gas logs if enabled (i.e. Just) , _evalLogGas :: !(Maybe [(Text,Gas)]) -- | Accumulate events @@ -360,7 +367,7 @@ data EvalState = EvalState { } deriving (Show, Generic) makeLenses ''EvalState instance NFData EvalState -instance Default EvalState where def = EvalState def def def def def def +instance Default EvalState where def = EvalState def def def def def def def -- | Interpreter monad, parameterized over back-end MVar state type. newtype Eval e a = diff --git a/src/Pact/Types/Verifier.hs b/src/Pact/Types/Verifier.hs new file mode 100644 index 000000000..459518942 --- /dev/null +++ b/src/Pact/Types/Verifier.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell #-} + +module Pact.Types.Verifier + ( VerifierName(..) + , Verifier(..) + , verifierName + , verifierProof + , verifierCaps + , ParsedVerifierProof(..) + ) where + +import Control.DeepSeq +import Control.Lens +import Data.Aeson +import Data.Text +import GHC.Generics +import Test.QuickCheck(Arbitrary(..), scale) + +import qualified Pact.JSON.Encode as J + +import Pact.Types.Orphans() +import Pact.Types.PactValue +import Pact.Types.Capability + +newtype VerifierName = VerifierName Text + deriving newtype (J.Encode, Arbitrary, NFData, Eq, Show, Ord, FromJSON) + deriving stock Generic + +data Verifier prf = Verifier + { _verifierName :: VerifierName + , _verifierProof :: prf + , _verifierCaps :: [UserCapability] + } + deriving (Eq, Show, Generic, Ord, Functor, Foldable, Traversable) + +makeLenses ''Verifier + +instance NFData a => NFData (Verifier a) +instance Arbitrary a => Arbitrary (Verifier a) where + arbitrary = + Verifier <$> + (VerifierName . pack <$> arbitrary) <*> + arbitrary <*> + scale (min 10) arbitrary +instance J.Encode a => J.Encode (Verifier a) where + build va = J.object + [ "name" J..= _verifierName va + , "proof" J..= _verifierProof va + , "clist" J..= J.Array (_verifierCaps va) + ] +instance FromJSON a => FromJSON (Verifier a) where + parseJSON = withObject "Verifier" $ \o -> do + name <- o .: "name" + proof <- o .: "proof" + caps <- o .: "clist" + return $ Verifier name proof caps + +newtype ParsedVerifierProof = ParsedVerifierProof PactValue + deriving newtype (NFData, Eq, Show, Ord, FromJSON) + deriving stock Generic + +instance J.Encode ParsedVerifierProof where + build (ParsedVerifierProof as) = J.build as + +instance Arbitrary ParsedVerifierProof where + arbitrary = ParsedVerifierProof <$> arbitrary diff --git a/tests/ClientSpec.hs b/tests/ClientSpec.hs index 2dbedd7ff..b834a357d 100644 --- a/tests/ClientSpec.hs +++ b/tests/ClientSpec.hs @@ -23,13 +23,13 @@ import Utils simpleServerCmd :: IO (Command Text) simpleServerCmd = do simpleKeys <- DynEd25519KeyPair <$> genKeyPair - mkExec "(+ 1 2)" Null def [(simpleKeys,[])] Nothing (Just "test1") + mkExec "(+ 1 2)" Null def [(simpleKeys,[])] [] Nothing (Just "test1") simpleServerCmdWithPactErr :: IO (Command Text) simpleServerCmdWithPactErr = do simpleKeys <- DynEd25519KeyPair <$> genKeyPair - mkExec "(+ 1 2 3)" Null def [(simpleKeys,[])] Nothing (Just "test1") + mkExec "(+ 1 2 3)" Null def [(simpleKeys,[])] [] Nothing (Just "test1") spec :: Spec spec = describe "Servant API client tests" $ do diff --git a/tests/GasModelSpec.hs b/tests/GasModelSpec.hs index de764537a..184b91634 100644 --- a/tests/GasModelSpec.hs +++ b/tests/GasModelSpec.hs @@ -288,4 +288,3 @@ _diffGoldens g1 g2 = do encodeYamlFile "diff.yaml" $ formatJson $ Map.unionWith merge y1 y2 where formatJson = J.Object . fmap (J.Array. fmap J.Aeson) - diff --git a/tests/GoldenSpec.hs b/tests/GoldenSpec.hs index 72002c4e2..c0e13dbf6 100644 --- a/tests/GoldenSpec.hs +++ b/tests/GoldenSpec.hs @@ -156,7 +156,7 @@ doCRTest' ec tn code = beforeAllWith initRes $ initRes s = do let dbEnv = PactDbEnv (view (rEnv . eePactDb) s) (view (rEnv . eePactDbVar) s) cmd = Command payload [] initialHash - payload = Payload exec "" pubMeta [] Nothing + payload = Payload exec "" pubMeta [] Nothing Nothing pubMeta = def parsedCode = either error id $ parsePact code exec = Exec $ ExecMsg parsedCode (toLegacyJson Null) diff --git a/tests/HyperlaneSpec.hs b/tests/HyperlaneSpec.hs new file mode 100644 index 000000000..933e6e163 --- /dev/null +++ b/tests/HyperlaneSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module HyperlaneSpec (spec) where + +import Control.Lens ((^?), at, _Just, _1) +import Crypto.Hash.HyperlaneMessageId (hyperlaneMessageId) +import Data.Default (def) +import Data.Map (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Pact.Types.Runtime (FieldKey, Object(..), ObjectMap(..), Term, Literal(..), tLit, tStr, asString, toTObject, Type(..), _TObject) +import Test.Hspec + +spec :: Spec +spec = describe "hyperlane" $ do + describe "hyperlane-message-id" $ do + it "computes the correct message id" $ do + let obj' = mkObject + [ ("message",) $ obj + [ ("version", tLit $ LInteger 1) + , ("nonce", tLit $ LInteger 325) + , ("originDomain", tLit $ LInteger 626) + , ("sender", tStr $ asString ("0x6b622d746f6b656e2d726f75746572" :: Text)) + , ("destinationDomain", tLit $ LInteger 1) + , ("recipient", tStr $ asString ("0x71C7656EC7ab88b098defB751B7401B5f6d8976F" :: Text)) + , ("tokenMessage", obj + [ ("recipient", tStr $ asString ("0x71C7656EC7ab88b098defB751B7401B5f6d8976F" :: Text)) + , ("amount", tLit $ LDecimal 10000000000000000000) + ] + ) + ] + ] + Just message <- pure (unwrapObject obj' ^? at "message" . _Just . _TObject . _1) + hyperlaneMessageId message `shouldBe` "0x97d98aa7fdb548f43c9be37aaea33fca79680247eb8396148f1df10e6e0adfb7" + +mkObject :: [(FieldKey, Term n)] -> Object n +mkObject ps = Object (ObjectMap (Map.fromList ps)) TyAny Nothing def + +obj :: [(FieldKey, Term n)] -> Term n +obj = toTObject TyAny def + +unwrapObject :: Object n -> Map FieldKey (Term n) +unwrapObject o = _objectMap (_oObject o) diff --git a/tests/PactContinuationSpec.hs b/tests/PactContinuationSpec.hs index 8500f9c0f..939f17a0f 100644 --- a/tests/PactContinuationSpec.hs +++ b/tests/PactContinuationSpec.hs @@ -32,12 +32,15 @@ import Test.Hspec import Pact.ApiReq import Pact.Server.API import Pact.Types.API +import Pact.Types.Capability import Pact.Types.Command import Pact.Types.Crypto as Crypto +import Pact.Types.Names import Pact.Types.PactValue (PactValue(..)) import Pact.Types.Pretty import Pact.Types.Runtime import Pact.Types.SPV +import Pact.Types.Verifier import qualified Pact.JSON.Encode as J import Utils @@ -55,11 +58,12 @@ spec = describe "pacts in dev server" $ do describe "testElideModRefEvents" testElideModRefEvents describe "testNestedPactContinuation" testNestedPactContinuation describe "testNestedPactYield" testNestedPactYield + describe "testVerifiers" testVerifiers testElideModRefEvents :: Spec testElideModRefEvents = do it "elides modref infos" $ do - cmd <- mkExec code Null def [] Nothing Nothing + cmd <- mkExec code Null def [] [] Nothing Nothing results <- runAll' [cmd] noSPVSupport testFlags runResults results $ do shouldMatch cmd $ ExpectResult $ \cr -> @@ -67,7 +71,7 @@ testElideModRefEvents = do (not . ("refInfo" `isInfixOf`) . BSL8.unpack) it "doesn't elide on backcompat" $ do - cmd <- mkExec codePreFork Null def [] Nothing Nothing + cmd <- mkExec codePreFork Null def [] [] Nothing Nothing results <- runAll' [cmd] noSPVSupport backCompatFlags runResults results $ do shouldMatch cmd $ ExpectResult $ \cr -> @@ -236,7 +240,7 @@ testNestedPactContinuation = do testSimpleServerCmd :: IO (Maybe (CommandResult Hash)) testSimpleServerCmd = do simpleKeys <- DynEd25519KeyPair <$> genKeyPair - cmd <- mkExec "(+ 1 2)" Null def [(simpleKeys,[])] Nothing (Just "test1") + cmd <- mkExec "(+ 1 2)" Null def [(simpleKeys,[])] [] Nothing (Just "test1") allResults <- runAll [cmd] return $ HM.lookup (cmdToRequestKey cmd) allResults @@ -1304,6 +1308,21 @@ testPriceNegDownBadCaps = do twoPartyEscrow [tryNegUpCmd] $ checkContHash [req] $ do tryNegUpCmd `failsWith` (`shouldBe` "Keyset failure (keys-all): [7d0c9ba1...]") +testVerifiers :: Spec +testVerifiers = context "using a verifier" $ it "should parse and run" $ do + simpleKeys <- DynEd25519KeyPair <$> genKeyPair + cmd <- mkExec "(+ 1 2)" Null def + [(simpleKeys,[])] + [Verifier + (VerifierName "TESTING-VERIFIER") + (ParsedVerifierProof $ PLiteral (LDecimal 3)) + [SigCapability (QualifiedName (ModuleName "coin" Nothing) "TRANSFER" def) [PLiteral (LString "jeff"), PLiteral (LDecimal 10)]]] + Nothing (Just "test1") + allResults <- runAll [cmd] + runResults allResults $ + succeeds cmd + + @@ -1356,7 +1375,7 @@ makeExecCmd keyPairs code = makeExecCmd' Nothing keyPairs code makeExecCmd' :: Maybe Text -> DynKeyPair -> Text -> IO (Command Text) makeExecCmd' nonce keyPairs code = mkExec code - (object ["admin-keyset" .= [formatPubKeyForCmd keyPairs]]) def [(keyPairs,[])] Nothing nonce + (object ["admin-keyset" .= [formatPubKeyForCmd keyPairs]]) def [(keyPairs,[])] [] Nothing nonce formatPubKeyForCmd :: DynKeyPair -> Value @@ -1392,7 +1411,7 @@ makeContCmd' -- ^ nonce -> IO (Command Text) makeContCmd' contProofM keyPairs isRollback cmdData pactExecCmd step nonce = - mkCont (getPactId pactExecCmd) step isRollback cmdData def [(keyPairs,[])] (Just nonce) contProofM Nothing + mkCont (getPactId pactExecCmd) step isRollback cmdData def [(keyPairs,[])] [] (Just nonce) contProofM Nothing textVal :: Text -> PactValue textVal = PLiteral . LString diff --git a/tests/PactTests.hs b/tests/PactTests.hs index 661eee9ef..f8cedd77c 100644 --- a/tests/PactTests.hs +++ b/tests/PactTests.hs @@ -24,6 +24,7 @@ import qualified DocgenSpec import qualified GasModelSpec import qualified GoldenSpec import qualified HistoryServiceSpec +import qualified HyperlaneSpec import qualified PactContinuationSpec import qualified PersistSpec import qualified RemoteVerifySpec @@ -60,6 +61,7 @@ main = hspec $ parallel $ do describe "GasModelSpec" GasModelSpec.spec describe "GoldenSpec" GoldenSpec.spec describe "HistoryServiceSpec" HistoryServiceSpec.spec + describe "HyperlaneSpec" HyperlaneSpec.spec describe "PactContinuationSpec" PactContinuationSpec.spec describe "PersistSpec" PersistSpec.spec describe "RemoteVerifySpec" RemoteVerifySpec.spec diff --git a/tests/SchemeSpec.hs b/tests/SchemeSpec.hs index 8bb03e075..1c5028977 100644 --- a/tests/SchemeSpec.hs +++ b/tests/SchemeSpec.hs @@ -89,7 +89,7 @@ toSigners kps = return $ map makeSigner kps toExecPayload :: [Signer] -> Text -> ByteString toExecPayload signers t = J.encodeStrict payload where - payload = Payload (Exec (ExecMsg t $ toLegacyJson Null)) "nonce" (J.Aeson ()) signers Nothing + payload = Payload (Exec (ExecMsg t $ toLegacyJson Null)) "nonce" (J.Aeson ()) signers Nothing Nothing shouldBeProcFail :: ProcessedCommand () ParsedCode -> Expectation diff --git a/tests/Test/Pact/Utils/LegacyValue.hs b/tests/Test/Pact/Utils/LegacyValue.hs index 0b32fd19c..c7cdd5484 100644 --- a/tests/Test/Pact/Utils/LegacyValue.hs +++ b/tests/Test/Pact/Utils/LegacyValue.hs @@ -67,6 +67,7 @@ import Pact.Types.SigData import Pact.Types.SPV import Pact.Types.SQLite import Pact.Types.Term.Arbitrary () +import Pact.Types.Verifier import Pact.PersistPactDb import qualified Pact.JSON.Encode as J @@ -1039,6 +1040,12 @@ spec_pact_types_command = , Case checkAesonCompat , Case checkLegacyValueCompat ] + spec_case @(Verifier ParsedVerifierProof) + [ Case checkRoundtrip + , Case checkRoundtrip2 + , Case checkAesonCompat + , Case checkLegacyValueCompat + ] -- ---------------------------------------------- -- spec_pact_types_sigdata :: Spec diff --git a/tests/pact/caps.repl b/tests/pact/caps.repl index 5be505556..f8305a93d 100644 --- a/tests/pact/caps.repl +++ b/tests/pact/caps.repl @@ -60,7 +60,7 @@ (defpact test-pact-guards (id:string) (step (step1 id)) - (step (step2 (read-msg "id")))) + (step (let ((s2 (step2 (read-msg "id")))) "step2"))) (defun step1 (id:string) (insert guard-table id { "g": (create-pact-guard "test")})) @@ -207,7 +207,7 @@ (env-data { "id": "a"}) -(expect "pact enforce succeeds" 1 (at 'result (continue-pact 1 false (hash "pact-guards-a-id")))) +(expect "pact enforce succeeds" "step2" (continue-pact 1 false (hash "pact-guards-a-id"))) (pact-state true) (env-hash (hash "pact-guards-b-id")) diff --git a/tests/pact/hyperlane-message-id.repl b/tests/pact/hyperlane-message-id.repl new file mode 100644 index 000000000..1fcfd5ee2 --- /dev/null +++ b/tests/pact/hyperlane-message-id.repl @@ -0,0 +1,3 @@ +;; Test hyperlane-message-id + +(expect "computes the correct message id" "0x97d98aa7fdb548f43c9be37aaea33fca79680247eb8396148f1df10e6e0adfb7" (hyperlane-message-id {"destinationDomain": 1,"nonce": 325,"originDomain": 626,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F","sender": "0x6b622d746f6b656e2d726f75746572","tokenMessage": {"amount": 10000000000000000000.0,"recipient": "0x71C7656EC7ab88b098defB751B7401B5f6d8976F"},"version": 1})) diff --git a/tests/pact/tc.repl b/tests/pact/tc.repl index b16391fcd..20c59ff6b 100644 --- a/tests/pact/tc.repl +++ b/tests/pact/tc.repl @@ -329,6 +329,16 @@ "test anon lambdas" (map (lambda (i) (> i 1)) [1 2 3])) + (defpact fail-steps-type-missmatch: integer () + "test type missmatch of steps" + (step "missmatch") + (step 1)) + + (defpact tc-steps-type-pass: integer () + "test type match of steps" + (step 1) + (step 1)) + ) (create-table persons) diff --git a/tests/pact/verifier-test.repl b/tests/pact/verifier-test.repl new file mode 100644 index 000000000..3065c6ca0 --- /dev/null +++ b/tests/pact/verifier-test.repl @@ -0,0 +1,75 @@ +(module m GOV + (defcap GOV () true) + + (defcap GOOD () + (enforce-verifier 'HYPERLANE) + ) + + (defcap BAD () + (enforce-verifier 'HYPERLANE) + ) + + (defcap OUTERGOOD () + (enforce-verifier 'HYPERLANE) + (compose-capability (GOOD)) + ) + + (defun outergood-mgr:integer (a:integer b:integer) (print a) (+ a b)) + + (defcap OUTERGOOD-MANAGED (param:integer) + ; @managed param outergood-mgr + ; (enforce-verifier 'HYPERLANE) + ; (compose-capability (GOOD)) + (compose-capability (INNERGOOD-MANAGED param)) + ) + + (defcap INNERGOOD-MANAGED (param:integer) + @managed param outergood-mgr + (enforce-verifier 'HYPERLANE) + (compose-capability (GOOD)) + ) + + (defun good () + (with-capability (GOOD) 1) + ) + + (defun outergood-managed () + (with-capability (OUTERGOOD-MANAGED 1) + 1 + ) + ) + + (defun outergood () + (with-capability (OUTERGOOD) 1) + ) + + (defun bad () + (with-capability (GOOD) + (with-capability (BAD) 1) + ) + ) + + (defun enforce-outside-cap () + (with-capability (GOOD) + (enforce-verifier "HYPERLANE") + ) + ) +) + + +(env-verifiers [{"name":"HYPERLANE", "caps":[(OUTERGOOD)]}]) + +(expect "outergood succeeds" (outergood) 1) +(expect-failure "bad acquisition fails: not in scope" (bad)) +(expect-failure "good acquisition fails: not in scope" (good)) + +(env-verifiers [{"name":"HYPERLANE", "caps":[(GOOD)]}]) + +(expect-failure "enforce-outside-cap fails: cannot use enforce-verifier outside of cap evaluation" (enforce-outside-cap)) +(expect-failure "outergood acquisition fails: not in scope" (outergood)) +(expect "good succeeds" (good) 1) +(expect-failure "bad acquisition fails: not in scope" (bad)) + +(env-sigs [{"key":"jose", "caps":[(INNERGOOD-MANAGED 0)]}]) +(env-verifiers [{"name":"HYPERLANE", "caps":[(OUTERGOOD-MANAGED 1)]}]) +(expect "outergood-managed succeeds" (outergood-managed) 1) diff --git a/tests/pact/versions.repl b/tests/pact/versions.repl new file mode 100644 index 000000000..0f914d58a --- /dev/null +++ b/tests/pact/versions.repl @@ -0,0 +1,26 @@ + + +(expect + "pact version bounds work for current pact version" + true + (enforce-pact-version "3.0.0" "6.0.0")) + +(expect + "enforce-pact-version works for current pact version" + true + (enforce-pact-version (pact-version))) + +(expect-failure + "pact version bounds fail for current version if wrong bounds" + (enforce-pact-version "6.0.0" "100.0.0")) + +;; regression #1327 +(expect + "enforce-pact-version succeeds for current version if lower bound set" + true + (enforce-pact-version "1.0.0")) + +(expect + "enforce-pact-version succeeds (double digit regression)" + true + (enforce-pact-version "3.0000.0" "88.420.0"))