From 9b863c0183a207255a24542f019e9167fcec82ca Mon Sep 17 00:00:00 2001 From: June <38109440+DevopsGoth@users.noreply.github.com> Date: Tue, 29 Aug 2023 15:55:01 -0600 Subject: [PATCH 1/4] Update applications.yml --- .github/workflows/applications.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.github/workflows/applications.yml b/.github/workflows/applications.yml index f7f14d72b..bd51e3f9a 100644 --- a/.github/workflows/applications.yml +++ b/.github/workflows/applications.yml @@ -3,6 +3,10 @@ name: Build and publish application binaries on: workflow_dispatch: push: + paths: + - '**' + - '!.github/**' + - '.github/workflows/applications.yml' jobs: build: From 1ed1a26bd645851c8cb04e783d6cd28887ff8465 Mon Sep 17 00:00:00 2001 From: June <38109440+DevopsGoth@users.noreply.github.com> Date: Tue, 29 Aug 2023 15:56:29 -0600 Subject: [PATCH 2/4] Proper nix.yml Caching for x86 ubuntu/mac, m1 mac --- .github/workflows/nix.yml | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml index e1b7e475d..108af0d7f 100644 --- a/.github/workflows/nix.yml +++ b/.github/workflows/nix.yml @@ -3,19 +3,25 @@ name: Build and cache with Nix on: workflow_dispatch: push: - + paths: + - '**' + - '!.github/**' + - '.github/workflows/nix.yml' + jobs: build-and-cache: runs-on: ${{ matrix.os }} + timeout-minutes: 740 strategy: + fail-fast: false matrix: - os: [ubuntu-latest, mac-m1] + os: [ubuntu-latest, macos-latest, macos-m1] steps: - name: Checkout repository uses: actions/checkout@v3 - name: Set up Nix with caching - uses: kadena-io/setup-nix-with-cache@v1 + uses: kadena-io/setup-nix-with-cache/by-root@v3 with: cache_url: s3://nixcache.chainweb.com?region=us-east-1 signing_private_key: ${{ secrets.NIX_CACHE_PRIVATE_KEY }} @@ -27,8 +33,10 @@ jobs: aws-secret-access-key: ${{ secrets.NIX_CACHE_AWS_SECRET_ACCESS_KEY }} aws-region: us-east-1 + - name: Give root user AWS credentials + uses: kadena-io/setup-nix-with-cache/copy-root-aws-credentials@v3 + - name: Build and cache artifacts - timeout-minutes: 740 run: | - echo Building the default package and its devShell - nix build .#check + echo Building the project and its devShell + nix build .#check --log-lines 500 --show-trace From 6456925898eb4a10d3c1e375d45a09d07000c4dd Mon Sep 17 00:00:00 2001 From: rsoeldner Date: Tue, 10 Oct 2023 10:20:24 +0200 Subject: [PATCH 3/4] remove additionl ci and rely on nix --- .github/workflows/applications.yml | 69 ------------------------------ 1 file changed, 69 deletions(-) delete mode 100644 .github/workflows/applications.yml diff --git a/.github/workflows/applications.yml b/.github/workflows/applications.yml deleted file mode 100644 index bd51e3f9a..000000000 --- a/.github/workflows/applications.yml +++ /dev/null @@ -1,69 +0,0 @@ -name: Build and publish application binaries - -on: - workflow_dispatch: - push: - paths: - - '**' - - '!.github/**' - - '.github/workflows/applications.yml' - -jobs: - build: - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - ghc: ['8.10.7'] - cabal: ['3.8'] - os: ['ubuntu-latest', 'macOS-latest', 'windows-latest'] - - steps: - - name: Checkout repository - uses: actions/checkout@v3 - - # Haskell Setup - - name: Install GHC ${{matrix.ghc}} and Cabal ${{matrix.cabal}} - uses: haskell/actions/setup@v2 - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: ${{ matrix.cabal }} - - - name: Confirm GHC and Cabal installation - run: | - ghc --version - cabal --version - - # Project Setup - - name: Create cabal.project.local - shell: bash - run: | - cat > cabal.project.local < Date: Mon, 16 Oct 2023 12:41:49 -0400 Subject: [PATCH 4/4] caps full semantics + db --- pact-core-tests/pact-tests/caps.repl | 926 ++++++++++++++++++ pact-core/Pact/Core/Builtin.hs | 5 +- pact-core/Pact/Core/Capabilities.hs | 20 +- pact-core/Pact/Core/Compile.hs | 10 +- pact-core/Pact/Core/Environment.hs | 2 +- pact-core/Pact/Core/Errors.hs | 2 + pact-core/Pact/Core/Guards.hs | 48 + pact-core/Pact/Core/IR/Desugar.hs | 88 +- pact-core/Pact/Core/IR/Eval/CEK.hs | 313 +++--- pact-core/Pact/Core/IR/Eval/RawBuiltin.hs | 181 ++-- pact-core/Pact/Core/IR/Eval/Runtime/Types.hs | 13 +- pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs | 62 +- pact-core/Pact/Core/IR/Term.hs | 13 +- pact-core/Pact/Core/Names.hs | 19 +- pact-core/Pact/Core/PactValue.hs | 3 +- pact-core/Pact/Core/Pretty.hs | 18 +- pact-core/Pact/Core/Repl.hs | 14 +- pact-core/Pact/Core/Repl/Compile.hs | 61 +- .../Pact/Core/Repl/Runtime/ReplBuiltin.hs | 175 +--- pact-core/Pact/Core/Repl/Utils.hs | 27 +- pact-core/Pact/Core/Syntax/Parser.y | 1 - 21 files changed, 1567 insertions(+), 434 deletions(-) create mode 100644 pact-core-tests/pact-tests/caps.repl diff --git a/pact-core-tests/pact-tests/caps.repl b/pact-core-tests/pact-tests/caps.repl new file mode 100644 index 000000000..9688b6914 --- /dev/null +++ b/pact-core-tests/pact-tests/caps.repl @@ -0,0 +1,926 @@ + +(begin-tx) +; (env-exec-config ["DisablePact44"]) + +(env-data { "kall": ["a" "b" "c"], "kadmin": ["admin"] }) +(define-keyset 'kall) +(define-keyset 'kadmin) + +(env-keys ["admin"]) + +(module other GOV + (defcap GOV () true) + (defun enforce-a-guard (g) (enforce-guard g))) + +(module caps 'kadmin + + (defschema guards g:guard) + (deftable guard-table:{guards}) + + (defschema int-row i:integer) + (deftable ints:{int-row}) + (defschema ints-key k:string) + + (defschema yieldschema result:integer) + + (defcap GRANTED () true) + + (defcap KALL-CAP () (enforce-keyset 'kall)) + + (defun with-kall () + (with-capability (KALL-CAP) 1)) + + (defcap KEYSET-ID-CAP (id:string) + (enforce-keyset id)) + + (defun test-id-cap (id) + (with-capability (KEYSET-ID-CAP id) (test-require id))) + + (defun test-require (id) + (require-capability (KEYSET-ID-CAP id)) 1) + + (defun get-module-guard () + (create-module-guard "test")) + + (defun msg-keyset-user-guard (key:string) + (create-user-guard (enforce-msg-keyset key))) + + (defun enforce-msg-keyset (key:string) + (enforce-keyset (read-keyset key))) + + (defun create-bad-db-user-guard () + @doc "Creates a user guard which tries to read from the DB, which is not allowed. This will fail when the guard is enforced." + ; this insert succeeds: + (insert ints 'x {'i: 0}) + (create-user-guard (bad-user-guard-fun 'x))) + + (defun bad-user-guard-fun (x:string) + (let ((row (read ints x))) + (enforce (= 0 (at 'i row)) "int wasn't zero"))) + + ; (defpact test-pact-guards (id:string) + ; (step (step1 id)) + ; (step (step2 (read-msg "id")))) + + ; (defun step1 (id:string) + ; (insert guard-table id { "g": (create-pact-guard "test")})) + + (defun step2:object{yieldschema} (id:string) + (enforce-guard (get-guard id)) + { "result": 1 }) + + (defun get-guard (id:string) + (at 'g (read guard-table id))) + + (defcap COMPOSING-CAP () + (compose-capability (KALL-CAP))) + + (defun bad-compose-cap () + (compose-capability (KALL-CAP))) + + (defun test-compose-cap () + (with-capability (COMPOSING-CAP) + (require-capability (KALL-CAP)))) + + (defun test-granted () + (require-capability (GRANTED))) + + ; (defcap BAD_WITH_CAP () + ; (with-capability (GRANTED) true)) + + ; (defun bad-with-cap () + ; (with-capability (BAD_WITH_CAP) true)) + + (defun test-module-guard-other () + (other.enforce-a-guard (get-module-guard)) + "success") + + (defun bad-user-guard-compose () + (with-capability (BAD_USER_GUARD_COMPOSE) true)) + + (defcap BAD_USER_GUARD_COMPOSE () + (enforce-guard (create-user-guard (bad-compose-cap)))) + +) + +(create-table guard-table) +(create-table ints) + +(commit-tx) + +(begin-tx) +(module caps-shadow 'kadmin + (defcap KEYSET-ID-CAP (id:string) true) + (defun bad-shadow-granted (id) + (with-capability (KEYSET-ID-CAP id) + (caps.test-require id)))) +(commit-tx) + +; (typecheck 'caps) + +(begin-tx) +(use caps) + +(expect-failure "with-kall should fail w/o kall ks" (with-kall)) + +(env-keys ["a" "b" "c"]) + +(expect "with-kall succeeds with kall ks" 1 (with-kall)) + +(env-data { "k1": ["k1"], "k2": ["k2"] }) +(define-keyset "k1") +(define-keyset "k2") + +(expect-failure "cap k1 fails w/o key" (test-id-cap "k1")) +(expect-failure "cap k2 fails w/o key" (test-id-cap "k2")) + +(env-keys ["k1"]) + +(expect "cap k1 succeeds" 1 (test-id-cap "k1")) +(expect-failure "direct call to test-require fails for k1" + (require-capability (KEYSET-ID-CAP "k1"))) +(expect-failure "cap k2 fails w/o key" (test-id-cap "k2")) + +(env-keys ["k2"]) +(expect-failure "cap k1 fails w/o key" (test-id-cap "k1")) +(expect-failure "direct call to test-require fails for k2" + (require-capability (KEYSET-ID-CAP "k2"))) +(expect "cap k2 succeeds" 1 (test-id-cap "k2")) + +; (expect-failure "top-level with-capability fails" +; (with-capability (KEYSET-ID-CAP "k2") 1)) + +(expect-failure "module guard fails w/o admin" + (enforce-guard (get-module-guard))) + +(env-keys ["admin","k2"]) +(enforce-guard (get-module-guard)) +(expect "top-level with-capability succeeds with module admin" + 1 (with-capability (KEYSET-ID-CAP "k2") 1)) + +(commit-tx) +(begin-tx) +(use caps) + +(env-data { "k1": ["k1"], "k2": ["k2"], "k3" : ["k3"] }) + +(expect-failure + "k3 fails ref guard construction when no keyset is defined" + (keyset-ref-guard "k3")) + +(define-keyset "k3" (read-keyset "k3")) + +(expect + "k3 succeeds now that a keyset is defined with that name" + "'k3" + (format "{}" [(keyset-ref-guard "k3")])) + +(expect-failure + "k3 cannot succeed since its keys are not in scope" + (enforce-guard (keyset-ref-guard "k3"))) + +(env-keys ["k3"]) + +(expect + "k3 succeeds now that keys are in scope" + "true" + (format "{}" [(enforce-guard (keyset-ref-guard "k3"))])) + +(env-keys ["k1"]) + +(enforce-guard (msg-keyset-user-guard "k1")) +(expect-failure "user guard reading keyset k2 fails" + (enforce-guard (msg-keyset-user-guard "k2"))) + +(enforce-guard (keyset-ref-guard "k1")) +(expect-failure "keyset ref guard k2" + (enforce-guard (keyset-ref-guard "k2"))) + +(let ((bad-db-user-guard (create-bad-db-user-guard))) + (expect-failure "reading db from within user guard" (enforce-guard bad-db-user-guard))) + +(env-hash (hash "pact-guards-a-id")) ;; equivalent of pact-id +; (test-pact-guards "a") + +; (pact-state true) ;; clears pact state +; (let ((g (get-guard "a"))) ;; doing let so db failure doesn't confuse below +; (expect-failure "enforcing pact guard outside of pact" (enforce-guard g))) + +; (env-data { "id": "a"}) + +; (expect "pact enforce succeeds" 1 (at 'result (continue-pact 1 false (hash "pact-guards-a-id")))) + +; (pact-state true) +; (env-hash (hash "pact-guards-b-id")) +; (test-pact-guards "b") +; (expect-failure "pact enforce fails in pact 5 for id 'a'" (continue-pact 1 false (hash "pact-guards-b-id"))) + +(env-keys ["a" "b" "c"]) +(expect-failure "cannot compose caps at toplevel" (compose-capability (KALL-CAP))) +(expect-failure "cannot compose caps in defun" (bad-compose-cap)) +;compose test will validate that KALL-CAP was acquired +(test-compose-cap) +;now validate that KALL-CAP is gone +(expect-failure "KALL-CAP composed cap is revoked" (require-capability KALL-CAP)) +; defuns requiring magic capabilities should not work +(expect-failure "functions requiring restricted governance should fail" (test-granted)) +; bring magical capabilities into scope at repl scope +(test-capability (GRANTED)) +; defuns requiring magic capabilities should now work +(expect "functions requiring restricted governance should succeed after 'test-capability'" true (test-granted)) +(commit-tx) + +(use caps) +; revocation now makes functions requiring certain caps to now fail +(expect-failure "functions requiring restricted governance should fail after revocation" (test-granted)) + +; (expect-failure "nested with-capability fails" (bad-with-cap)) + +(expect-failure "shadowed cap fails" (caps-shadow.bad-shadow-granted "k1")) + +(expect "success enforcing module guard in foreign module" + "success" + (test-module-guard-other)) + +(env-keys ["k1"]) +(expect + "success requiring a capability in user guard" + true + (enforce-guard (create-user-guard (test-id-cap "k1")))) + +(expect-failure + "failure creating a user guard with a defcap" + (create-user-guard (KEYSET-ID-CAP "k1"))) + +(env-keys ["a" "b" "c"]) +(expect-failure + "user guard with compose fails" + (bad-user-guard-compose)) + + +;; +;; managed capability tests +;; + +(begin-tx) + +(module mgd-caps G + "Exercise managed capability functionality" + + (defcap G () (enforce false "module admin disabled")) + + (defcap O () "dummy empty cap" true) + + (defcap PAY (sender:string receiver:string amount:integer) + @managed amount PAY-mgr + (enforce-keyset (read-keyset sender))) + + (defun PAY-mgr (mgd req) + (let ((bal (- mgd req))) + (enforce (> req 0) "requested amount > 0") + (enforce (>= bal 0) (format "sufficient balance: {} {} {}" [bal req mgd])) + bal)) + + (defun pay (sender receiver amount) + (with-capability (PAY sender receiver amount) + amount)) + + (defcap PAY_ADMIN (receiver:string amount:integer) + @managed amount PAY-mgr + (enforce-guard (create-module-guard "foo"))) + + (defun pay-admin (receiver:string amount:integer) + (with-capability (PAY_ADMIN receiver amount) amount)) + ) + +(commit-tx) + +(begin-tx) +(use mgd-caps) +(env-data { "alice": ["alice"] }) + +(env-keys ["alice"]) + +(expect-failure + "cap not in sigs" + (pay "alice" "bob" 10)) + +(env-sigs [{ "key": "alice", + "caps": [(PAY "alice" "bob" 10) + ,(PAY "alice" "carl" 1)] }] ) + +(expect-failure + "Payment should fail on different sender" + "not installed" + (pay "dave" "bob" 6)) + + +(expect-failure + "Payment should fail on different receiver" + "not installed" + (pay "alice" "dave" 6)) + +(expect-failure + "Payment should fail with too-high balance" + "sufficient balance" + (pay "alice" "bob" 11)) + +(expect + "Success on first pmt" 6 + (pay "alice" "bob" 6)) + +(expect-failure + "2nd payment should fail with too-high balance" + "sufficient balance" + (pay "alice" "bob" 5)) + +(expect + "Success on second pmt" 4 + (pay "alice" "bob" 4)) + +(expect-failure + "3rd payment should fail with too-high balance" + "sufficient balance" + (pay "alice" "bob" 1)) + +(expect + "Payment to carl succeeds" 1 + (pay "alice" "carl" 1)) + +(expect-failure + "2nd payment to carl fails" + (pay "alice" "bob" 1)) + +(expect-failure + "module admin fails without cap" + "not installed" + (pay-admin "bob" 10)) + +(env-sigs [{ "key": "dummy", + "caps": [(PAY_ADMIN "bob" 10)] }]) + +(expect-failure + "module admin fails on diff receiver" + "not installed" + (pay-admin "dave" 10)) + +(expect-failure + "module admin fails on too-big balance" + "sufficient balance" + (pay-admin "bob" 12)) + +(expect + "module admin succeeds" + 6 + (pay-admin "bob" 6)) + +(expect-failure + "module admin fails on balance exceed" + "sufficient balance" + (pay-admin "bob" 5)) + +(expect + "module admin balance succeeds" + 4 + (pay-admin "bob" 4)) + +(expect-failure + "module admin fails on exhausted balance" + "sufficient balance" + (pay-admin "bob" 1)) + +;; make sure different arity caps can play nice + +(env-sigs + [{ "key": "carl", + "caps": [(O) + ,(PAY_ADMIN "alice" 10) + ,(PAY "carl" "alice" 1)] }]) +(env-data { "carl": ["carl"] }) + +(expect + "module admin alice succeeds" + 1 + (pay-admin "alice" 1)) + +(expect + "carl pay alice succeeds" + 1 + (pay "carl" "alice" 1)) + +(commit-tx) + +(begin-tx) + +(interface mgd-iface + (defcap C:bool (id:string) @managed id C-mgr) + (defschema c-schema + id:string) + (defun C-mgr:string + (m:string r:string)) + ) +(env-keys ["a"]) +(env-data { "a": ["a"] }) +(define-keyset 'a (read-keyset 'a)) +(module mgd-mod G + (defcap G () true) + (implements mgd-iface) + (defcap C:bool (id:string) @managed id C-mgr + (enforce-keyset id)) + (defun C-mgr:string + (m:string r:string) m) + + (defcap D (allow:bool) @managed allow D-mgr (enforce allow "allowed")) + (defun D-mgr (m r) m) + (defun acquireD (allowed:bool) (with-capability (D allowed) true)) + ) + +(expect + "can install cap specified in interface" + "Installed capability" + (install-capability (C "a"))) + +(expect-failure + "D not acquirable without install" + (acquireD true)) + +(expect-failure + "test install enforces capability test" + (test-capability (D false))) + +(expect + "test install succeeds" + () + (test-capability (D true))) + +(expect + "D acquirable post-install" + true + (acquireD true)) + + +;; test autonomous and sig-scoped +(commit-tx) +(begin-tx) + + +(module cap-install-test G + (defcap G () true) + + (defschema sch guard:guard) + (deftable tbl:{sch}) + + (defcap C (id:string param:integer flag:bool) + @managed flag C-mgr + (enforce-guard (at 'guard (read tbl id)))) + (defun C-mgr (m r) m) + + (defun go (id param) + (with-capability (C id param true) "success")) + + (defun setup (id guard) + (insert tbl id { 'guard: guard })) + + ) + +(create-table tbl) + +(module auto-cap-mod G + (defcap G () (enforce false "no admin")) + (defconst AUTO_ID "auto-cap-mod") + (defun setup-auto () + (cap-install-test.setup AUTO_ID (create-module-guard "m"))) + (defun go-auto () + "make call in-module to allow module guard to pass" + (go AUTO_ID 0)) + ) + +;; setup autonomous account +(setup-auto) +;; setup alice account +(env-data { "alice": ["alice"], "bob": ["bob"] }) +(setup "alice" (read-keyset 'alice)) +(setup "bob" (read-keyset 'bob)) + +(commit-tx) +(begin-tx) +(use auto-cap-mod) +(use cap-install-test) + +;; scenario: user signs but does not scope cap and not installed +(env-keys ["alice"]) +(expect-failure + "alice acquire fails with nothing installed" + "not installed" + (go "alice" 0)) + +;; scenario: autonomous call fails with no cap installed +(expect-failure + "autonomous failure with nothing installed" + "not installed" + (go-auto)) + +;; scenario: alice signs with no scope, direct install fails to acquire. +(env-keys ["alice"]) +(install-capability (C "alice" 0 true)) +(expect-failure + "Autonomous install on unscoped user sig cannot acquire" + "Keyset failure" + (go "alice" 0)) + +;; scenario: autonomous install, but fails anyway because call is not from module. +(install-capability (C AUTO_ID 0 true)) +(expect-failure + "Install for a module-admin-guarded cap w/o module access cannot acquire" + "no admin" + (go AUTO_ID 0)) + +;; success if called from auto context +(expect + "Install for a module-admin-guarded cap w/ module access acquires." + "success" + (go-auto)) + +;; scenario: bob installs with sig and succeeds +(env-sigs [{"key": "bob", "caps": [(C "bob" 0 true)]}]) +(expect + "Bob succeeds with sig-scoped install" + "success" + (go "bob" 0)) + +;; scenario: attacker tries different-parameterized cap than on sig list, fails +(install-capability (C "bob" 1 true)) +(expect-failure + "Attack with different parameters than signature cap fails" + "Keyset failure" + (go "bob" 1)) + +(commit-tx) +(begin-tx) + +;;; test empty caps after autonomous tx +;;; +(module test-empty-cap GOV + (defcap GOV () true) + + (defcap GUARD (g) + (enforce-guard (read-keyset g))) + + (defun enforce-cap (g) + (with-capability (GUARD g) + true)) + + (defun enforce-wo-cap (g) + (enforce-guard (read-keyset g))) +) + +(env-data {"alice-keyset": ["alice"]}) + +;; scenario: alice signs empty caps for non-managed cap, works +(env-sigs [{ "key": "alice", "caps": []}]) +(expect "empty works with bare keyset read" true (enforce-wo-cap "alice-keyset")) +(expect "empty works with keyset read in guard" true (enforce-wo-cap "alice-keyset")) + +;; scenario: alice signs caps, only works in non-managed cap +(env-sigs [{ "key": "alice", "caps": [(GUARD "alice-keyset")]}]) +(expect "cap-scoped works with cap" true (enforce-cap "alice-keyset")) +(expect-failure "cap-scoped does not work without cap" "Keyset failure" + (enforce-wo-cap "alice-keyset")) + + +(commit-tx) +(begin-tx) + + +;;; test auto-managed caps and iface matching + +(interface auto-caps-iface + (defcap CAP_A:bool (name:string) @managed) + (defcap CAP_B:bool (name:string times:integer) @managed) + ) +(commit-tx) + +(begin-tx) + +(module auto-caps-mod GOV + (implements auto-caps-iface) + (defcap GOV () true) + (defcap CAP_A:bool (name:string) + @managed + true) + (defcap CAP_B:bool (name:string times:integer) + @managed times capBMgr + true) + (defun capBMgr:integer (mgd:integer rqd:integer) + (enforce (> mgd 0) "all done") + (- mgd 1)) + (defun doA (name) + (with-capability (CAP_A name) true)) + (defun doB (name times) + (with-capability (CAP_B name times) true))) + +(expect + "auto managed installs" + "Installed capability" + (install-capability (CAP_A "auto-a"))) + +(expect + "user managed unspecified installs" + "Installed capability" + (install-capability (CAP_B "auto-b" 2))) + +(expect + "auto managed succeeds" + true + (doA "auto-a")) + +(expect + "event emitted" + [ {"module-hash": (at 'hash (describe-module 'auto-caps-mod)) + ,"name": "auto-caps-mod.CAP_A" + ,"params": ["auto-a"] + }] + (env-events true)) + +(expect-failure + "auto managed fails after first time" + "Capability already fired" + (doA "auto-a")) + +(expect + "user managed unspecified succeeds [2]" + true + (doB "auto-b" 2)) +(expect + "user managed unspecified succeeds [1]" + true + (doB "auto-b" 1)) + +(expect + "events in order" + [ {"module-hash": (at 'hash (describe-module 'auto-caps-mod)) + ,"name": "auto-caps-mod.CAP_B" + ,"params": ["auto-b" 2] + }, + {"module-hash": (at 'hash (describe-module 'auto-caps-mod)) + ,"name": "auto-caps-mod.CAP_B" + ,"params": ["auto-b" 1] + } + ] + (env-events true)) + +(expect-failure + "user managed unspecified fails" + "all done" + (doB "auto-b" 0)) + + +;; enforce-one-in-user-guard bug + +(module enforce-one-in-user-guard-bug G + (defcap G () true) + + (defun good () true) + + (defun enforce-one-in-guard (g) + (enforce-one + "should be able to enforce inner guard" + [(enforce-guard g)])) + +) + +(expect + "enforce-one in guard ok" true + (enforce-guard + (create-user-guard + (enforce-one-in-guard + (create-user-guard (good)))))) + +(env-events true) ;; clear events + +(module events G + (defcap G () true) + (defcap TOP (msg:string) + @event + (compose-capability (COMPOSED 1)) + (compose-capability (MIDDLE))) + + (defcap MIDDLE () + (compose-capability (COMPOSED 1)) ;; shouldn't fire twice + (compose-capability (COMPOSED 2)) ;; should fire + ) + + (defcap COMPOSED (i:integer) + @event + true) + + (defun go(msg:string) + (with-capability (TOP msg) + 1)) + + + (defcap EV () @event (enforce false "always fail")) + + (defcap MGD (i:integer) @managed (enforce false "always fail")) + + (defcap NON () true) + + (defun emit-ev () + (emit-event (EV))) + + (defun emit-mgd () + (emit-event (MGD 1))) + + (defun emit-non-event () + (emit-event (NON))) + +) + +(go "hi") +(expect + "nested events test" + [ { "module-hash": (at 'hash (describe-module 'events)) + , "name": "events.COMPOSED" + , "params": [1] } + { "module-hash": (at 'hash (describe-module 'events)) + , "name": "events.COMPOSED" + , "params": [2] } + { "module-hash": (at 'hash (describe-module 'events)) + , "name": "events.TOP" + , "params": ["hi"] } + ] + (env-events true)) + +(expect-failure + "emit-event: must be in module" + "Unable to resolve current calling module" + (emit-event (EV))) + +(expect-failure + "emit-event: non-event" + "must be managed or event defcap" + (emit-non-event)) + +(expect + "emit-event: event, does not evaluate" + [{ "module-hash": (at 'hash (describe-module 'events)) + , "name": "events.EV", "params": [] }] + (let ((a (emit-ev))) (env-events true))) + +(expect + "emit-event: managed, does not evaluate" + [{ "module-hash": (at 'hash (describe-module 'events)) + , "name": "events.MGD", "params": [1] }] + (let ((a (emit-mgd))) (env-events true))) + +(module recursive_caps g + (defcap g () true) + (defcap FOO () + (compose-capability (BAR))) + (defcap BAR () + (compose-capability (BAZ))) + (defcap BAZ () true) + (defun go-recursive-caps () + (with-capability (FOO) + (require-capability (BAZ)) + ))) + +(go-recursive-caps) ;; Run recursive cap acquisition + +;; +;; capability guards +;; + +(module cap-guards g + (defschema cg-schema g:guard) + (deftable cg-tbl:{cg-schema}) + (defcap g () true) + (defcap CAP1 (n:string) true) + (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)))) + ; ) +) +(create-table cg-tbl) + +(expect + "cap guard succeeds" + true + (test-cap-guard "A" "A")) + +(expect-failure + "cap guard fails on wrong cap" + "Capability not acquired" + (test-cap-guard "A" "B")) + +; (env-hash (hash 1)) + +; (cg-pact 'k1 'k1 "C" "C") +; (expect +; "cap pact guard succeeds" +; true +; (continue-pact 1)) + +; (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)) + +; (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)) +(commit-tx) + +(begin-tx) +; ; (env-exec-config ["DisablePact49"]) + + ; pact 48 caps + (interface ops + (defun op1:bool (a:string b:integer)) + (defun op2:bool (c:string d:bool)) + ) + + +(module caller G + (defcap G () true) + (defschema dep + callee:module{ops}) + (deftable deps:{dep}) + (defcap OP1 (a:string b:integer m:module{ops}) + @managed + true) + (defcap OP2 (c:string d:bool m:module{ops}) + @managed + true) + (defun op1-guard (a:string b:integer m:module{ops}) + (create-capability-guard (OP1 a b m))) + (defun op2-guard (c:string d:bool m:module{ops}) + (create-capability-guard (OP2 c d m))) + (defun callees:[module{ops}] () + (map (compose (read deps) (at "callee")) (keys deps))) + (defun call-op1 (a:string b:integer) + (map (lambda (m:module{ops}) + (install-capability (OP1 a b m)) + (with-capability (OP1 a b m) + (m::op1 a b))) + (callees))) + (defun call-op2 (c:string d:bool) + (map (lambda (m:module{ops}) + (install-capability (OP2 c d m)) + (with-capability (OP2 c d m) + (m::op2 c d))) + (callees))) +) +(create-table deps) + +(module callee-A G + (defcap G () true) + (implements ops) + (defun op1:bool (a:string b:integer) + (enforce-guard (op1-guard a b callee-A)) + true) + (defun op2:bool (c:string d:bool) + (enforce-guard (op2-guard c d callee-A)) + false) + + ) + +(module callee-B G + (defcap G () true) + (implements ops) + (defun op1:bool (a:string b:integer) + ;; out-of-band call to callee-A + (callee-A.op1 a b) + false) + (defun op2:bool (c:string d:bool) + (enforce-guard (op2-guard c d callee-B)) + true) + ) + +(insert deps "callee-A" { 'callee: callee-A }) +(insert deps "callee-B" { 'callee: callee-B }) + +(expect-failure + "out-of-band call fails" + "Capability not acquired" + (call-op1 "hello" 2)) +(expect + "normal case succeeds for both callees post-fork" + [false true] + (call-op2 "goodbye" false)) + +(commit-tx) diff --git a/pact-core/Pact/Core/Builtin.hs b/pact-core/Pact/Core/Builtin.hs index c041c9684..d3d587a20 100644 --- a/pact-core/Pact/Core/Builtin.hs +++ b/pact-core/Pact/Core/Builtin.hs @@ -262,6 +262,7 @@ data RawBuiltin | RawWhere | RawNotQ | RawHash + | RawCompose deriving (Eq, Show, Ord, Bounded, Enum) instance HasObjectOps RawBuiltin where @@ -377,6 +378,7 @@ rawBuiltinToText = \case RawWhere -> "where?" RawNotQ -> "not?" RawHash -> "hash" + RawCompose -> "compose" instance IsBuiltin RawBuiltin where builtinName = NativeName . rawBuiltinToText @@ -489,6 +491,7 @@ instance IsBuiltin RawBuiltin where RawWhere -> 3 RawNotQ -> 2 RawHash -> 1 + RawCompose -> 3 rawBuiltinNames :: [Text] @@ -556,7 +559,7 @@ instance IsBuiltin ReplBuiltins where REnvStackFrame -> 0 REnvChainData -> 1 REnvData -> 1 - REnvEvents -> 0 + REnvEvents -> 1 REnvHash -> 1 REnvKeys -> 1 REnvSigs -> 1 diff --git a/pact-core/Pact/Core/Capabilities.hs b/pact-core/Pact/Core/Capabilities.hs index 989cc6b76..200e86dc8 100644 --- a/pact-core/Pact/Core/Capabilities.hs +++ b/pact-core/Pact/Core/Capabilities.hs @@ -22,6 +22,7 @@ module Pact.Core.Capabilities ) where import Control.Lens +import Data.Text(Text) import Data.Set(Set) import Data.Default @@ -31,14 +32,16 @@ import Pact.Core.Names import Pact.Core.Hash data DefManagedMeta name - = DefManagedMeta - { _dmManagedArgIx :: Int - , _dmManagerFn :: FQNameRef name - } deriving (Show) + = DefManagedMeta Int (FQNameRef name) + | AutoManagedMeta + -- { _dmManagedArgIx :: Int + -- , _dmManagerFn :: FQNameRef name + deriving (Show) data DefCapMeta name = DefEvent - | DefManaged (Maybe (DefManagedMeta name)) + | DefManaged (DefManagedMeta name) + | Unmanaged deriving (Show) data CapForm name e @@ -104,9 +107,12 @@ data CapState name v instance (Ord name, Ord v) => Default (CapState name v) where def = CapState mempty mempty mempty mempty -data PactEvent name v +-- Todo: Is there a reason why module + name is +-- an unqualified +data PactEvent v = PactEvent - { _peToken :: CapToken name v + { _peName :: Text + , _peArgs :: [v] , _peModule :: ModuleName , _peModuleHash :: ModuleHash } deriving (Show, Eq) diff --git a/pact-core/Pact/Core/Compile.hs b/pact-core/Pact/Core/Compile.hs index a78194317..288b20ae8 100644 --- a/pact-core/Pact/Core/Compile.hs +++ b/pact-core/Pact/Core/Compile.hs @@ -14,6 +14,7 @@ import Control.Monad.State.Strict ( MonadIO(..), MonadState ) import Control.Monad.Except ( MonadError(throwError), liftEither ) import Control.Monad import Data.Maybe(mapMaybe) +import Data.Foldable(find) import Data.Proxy import Data.ByteString(ByteString) import qualified Data.Map.Strict as M @@ -105,11 +106,12 @@ evalModuleGovernance pdb interp = \case term = App (Builtin (liftRaw RawEnforceGuard) info) (pure ksrg) info _interpret interp term *> pure tl CapGov (ResolvedGov fqn) -> - use (evalState . loaded . loAllLoaded . at fqn) >>= \case + -- Todo: this does not allow us to delegate governance, which is an issue. + case find (\d -> defName d == _fqName fqn) (_mDefs md) of Just (DCap d) -> _interpret interp (_dcapTerm d) *> pure tl - -- Todo: Definitely fixable with a GADT - _ -> throwError (PEExecutionError (ModuleGovernanceFailure (Lisp._mName m)) (Lisp._mInfo m)) + _ -> + throwError (PEExecutionError (ModuleGovernanceFailure (Lisp._mName m)) (Lisp._mInfo m)) Just (InterfaceData iface _) -> throwError (PEExecutionError (CannotUpgradeInterface (_ifName iface)) (_ifInfo iface)) Nothing -> pure tl @@ -145,7 +147,7 @@ interpretTopLevel pdb interp (DesugarOutput ds lo0 _deps) = do mdata = InterfaceData iface deps' liftDbFunction (_ifInfo iface) (writeModule pdb Write (view ifName iface) mdata) let newLoaded = M.fromList $ toFqDep (_ifName iface) (_ifHash iface) - <$> mapMaybe (fmap DConst . preview _IfDConst) (_ifDefns iface) + <$> mapMaybe ifDefToDef (_ifDefns iface) loadNewModule = over loModules (M.insert (_ifName iface) mdata) . over loAllLoaded (M.union newLoaded) diff --git a/pact-core/Pact/Core/Environment.hs b/pact-core/Pact/Core/Environment.hs index f9f012afd..016df20e9 100644 --- a/pact-core/Pact/Core/Environment.hs +++ b/pact-core/Pact/Core/Environment.hs @@ -164,7 +164,7 @@ data EvalState b i = EvalState { _esCaps :: CapState QualifiedName PactValue , _esStack :: [StackFrame] - , _esEvents :: [PactEvent FullyQualifiedName PactValue] + , _esEvents :: [PactEvent PactValue] , _esLoaded :: Loaded b i } deriving Show diff --git a/pact-core/Pact/Core/Errors.hs b/pact-core/Pact/Core/Errors.hs index dde2d8418..c55dfd9c0 100644 --- a/pact-core/Pact/Core/Errors.hs +++ b/pact-core/Pact/Core/Errors.hs @@ -269,6 +269,8 @@ data EvalError | FormIllegalWithinDefcap Text | RunTimeTypecheckFailure ArgTypeError Type | NativeIsTopLevelOnly NativeName + | EventDoesNotMatchModule ModuleName + | InvalidEventCap FullyQualifiedName deriving Show instance Pretty EvalError where diff --git a/pact-core/Pact/Core/Guards.hs b/pact-core/Pact/Core/Guards.hs index b5db7e8db..319aa2a89 100644 --- a/pact-core/Pact/Core/Guards.hs +++ b/pact-core/Pact/Core/Guards.hs @@ -18,15 +18,22 @@ where import Data.Text(Text) import qualified Data.Set as S +import Pact.Core.Pretty import Pact.Core.Names newtype PublicKeyText = PublicKeyText { _pubKey :: Text } deriving (Eq,Ord,Show) +instance Pretty PublicKeyText where + pretty (PublicKeyText t) = pretty t + newtype KeySetName = KeySetName { _keysetName :: Text } deriving (Eq,Ord,Show) +instance Pretty KeySetName where + pretty (KeySetName ks) = "'" <> pretty ks + data Governance name = KeyGov KeySetName | CapGov (CapGovRef name) @@ -51,18 +58,36 @@ data KSPredicate name -- | CustomPredicate name deriving (Eq, Show, Ord) +instance Pretty (KSPredicate name) where + pretty = \case + KeysAll -> "keys-all" + Keys2 -> "keys2" + KeysAny -> "keys-any" + data KeySet name = KeySet { _ksKeys :: !(S.Set PublicKeyText) , _ksPredFun :: KSPredicate name } deriving (Eq, Show, Ord) +instance Pretty name => Pretty (KeySet name) where + pretty (KeySet ks f) = "KeySet" <+> commaBraces + [ "keys: " <> prettyList (S.toList ks) + , "pred: " <> pretty f + ] + data UserGuard name term = UserGuard { _ugFunction :: name , _ugArgs :: [term] } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) +instance (Pretty name, Pretty term) => Pretty (UserGuard name term) where + pretty (UserGuard fn args) = "UserGuard" <+> commaBraces + [ "fun: " <> pretty fn + , "args: " <> prettyList args + ] + data ModuleGuard = ModuleGuard { _mgModule :: ModuleName @@ -75,6 +100,12 @@ instance Eq ModuleGuard where instance Ord ModuleGuard where mg `compare` mg' = _mgModule mg `compare` _mgModule mg' +instance Pretty ModuleGuard where + pretty (ModuleGuard mg name) = "ModuleGuard" <+> commaBraces + [ "module: " <> pretty mg + , "name: " <> pretty name + ] + data CapabilityGuard name term = CapabilityGuard { _cgName :: !name @@ -90,9 +121,26 @@ data Guard name term | GModuleGuard ModuleGuard deriving (Eq, Ord, Show, Functor, Foldable, Traversable) +instance (Pretty name, Pretty term) => Pretty (Guard name term) where + pretty = \case + GKeyset ks -> pretty ks + GKeySetRef ks -> pretty ks + GUserGuard ug -> pretty ug + GCapabilityGuard cg -> pretty cg + GModuleGuard g -> pretty g + + data Namespace name term = Namespace { _nsName :: !NamespaceName , _nsUser :: !(Guard name term) , _nsAdmin :: !(Guard name term) } deriving (Eq, Show) + +instance (Pretty name, Pretty term) => Pretty (CapabilityGuard name term) where + pretty (CapabilityGuard cg args) = "CapabilityGuard" <+> commaBraces + [ "name: " <> pretty cg + , "args: " <> pretty args + -- todo: pactId when I merge defpcats + -- , "pactId: " <> pretty _cgPactId + ] diff --git a/pact-core/Pact/Core/IR/Desugar.hs b/pact-core/Pact/Core/IR/Desugar.hs index c036b8288..672a351f3 100644 --- a/pact-core/Pact/Core/IR/Desugar.hs +++ b/pact-core/Pact/Core/IR/Desugar.hs @@ -94,12 +94,6 @@ import qualified Pact.Core.Syntax.ParseTree as Lisp worth writing our own. -} --- data RNameKind --- = RNBound DeBruijn --- | RNTopLevel ModuleName ModuleHash DefKind --- | RNModRef ModuleName [ModuleName] --- deriving Show - type DesugarType = Lisp.Type data RenamerEnv b i @@ -107,7 +101,7 @@ data RenamerEnv b i { _reBinds :: Map Text (NameKind, Maybe DefKind) , _reVarDepth :: DeBruijn , _rePactDb :: PactDb b i - , _reCurrModule :: Maybe ModuleName + , _reCurrModule :: Maybe (ModuleName, [ModuleName]) , _reCurrDef :: Maybe DefKind } makeLenses ''RenamerEnv @@ -398,7 +392,7 @@ desugarDefun (Lisp.Defun defname (arg:args) mrt body _ _ i) = do let args' = toArg <$> (arg :| args) body' <- desugarLispTerm body view reCurrModule >>= \case - Just mn -> do + Just (mn,_) -> do let bodyLam = Lam (TLDefun mn defname) args' body' i pure $ Defun defname (NE.toList args') mrt bodyLam i Nothing -> throwDesugarError (NotAllowedOutsideModule "defun") i @@ -426,10 +420,10 @@ desugarDefMeta info args = \case case findIndex ((==) arg . view argName) args of Just index' -> let dmanaged = DefManagedMeta index' (FQParsed name) - in pure (DefManaged (Just dmanaged)) + in pure (DefManaged dmanaged) Nothing -> throwDesugarError (InvalidManagedArg arg) info - Nothing -> pure (DefManaged Nothing) + Nothing -> pure (DefManaged AutoManagedMeta) desugarDefCap :: (MonadDesugar raw reso info m) @@ -440,7 +434,7 @@ desugarDefCap (Lisp.DefCap dcn arglist rtype term _docs _model meta i) = Just _ -> do let arglist' = toArg <$> arglist term' <- desugarLispTerm term - meta' <- traverse (desugarDefMeta i arglist') meta + meta' <- maybe (pure Unmanaged) (desugarDefMeta i arglist') meta pure (DefCap dcn (length arglist) arglist' rtype term' meta' i) Nothing -> throwDesugarError (NotAllowedOutsideModule "defcap") i @@ -478,6 +472,7 @@ desugarIfDef = \case let args = toArg <$> margs pure $ IfDefCap n args rty i Lisp.IfDConst dc -> IfDConst <$> desugarDefConst dc + Lisp.IfDSchema ds -> IfDSchema <$> desugarDefSchema ds _ -> error "unimplemented: special interface decl forms in desugar" desugarDef @@ -501,7 +496,7 @@ desugarModule -> m (Module ParsedName DesugarType raw i) desugarModule (Lisp.Module mname mgov extdecls defs _ _ i) = do let (imports, blessed, implemented) = splitExts extdecls - defs' <- locally reCurrModule (const (Just mname)) $ traverse desugarDef (NE.toList defs) + defs' <- locally reCurrModule (const (Just (mname,[]))) $ traverse desugarDef (NE.toList defs) let mhash = ModuleHash (Hash "placeholder") pure $ Module mname mgov defs' blessed imports implemented mhash i where @@ -649,9 +644,8 @@ defCapSCC -> Set Text defCapSCC mn cd dc = case _dcapMeta dc of - Just (DefManaged (Just dmeta)) -> - let (FQParsed pn) = _dmManagerFn dmeta - in termSCC mn cd (_dcapTerm dc) <> parsedNameSCC mn cd pn + DefManaged (DefManagedMeta _ (FQParsed pn)) -> + termSCC mn cd (_dcapTerm dc) <> parsedNameSCC mn cd pn _ -> termSCC mn cd (_dcapTerm dc) @@ -676,6 +670,7 @@ ifDefSCC mn currDefs = \case IfDfun _ -> mempty IfDCap _ -> mempty IfDConst d -> defConstSCC mn currDefs d + IfDSchema ds -> foldMap (typeSCC mn currDefs) ( _dsSchema ds) -- Todo: this handles imports, rename? loadTopLevelMembers @@ -695,7 +690,7 @@ loadTopLevelMembers i mimports mdata binds = case mdata of InterfaceData iface _ -> do let ifname = _ifName iface let ifhash = _ifHash iface - dcDeps = mapMaybe (fmap DConst . preview _IfDConst) (_ifDefns iface) + dcDeps = mapMaybe ifDefToDef (_ifDefns iface) depMap = M.fromList $ toLocalDepMap ifname ifhash <$> dcDeps loadedDeps = M.fromList $ toLoadedDepMap ifname ifhash <$> dcDeps loadWithImports depMap loadedDeps @@ -764,7 +759,7 @@ loadInterface' iface deps = do let modName = _ifName iface mhash = _ifHash iface toDepMap def = (defName def, (NTopLevel modName mhash, defKind def)) - dcDeps = mapMaybe (fmap DConst . preview _IfDConst) (_ifDefns iface) + dcDeps = mapMaybe ifDefToDef (_ifDefns iface) dconstDeps = M.fromList $ toDepMap <$> dcDeps loadInterface iface deps dconstDeps dcDeps @@ -838,7 +833,7 @@ lookupModuleMember modName name i = do throwDesugarError (NoSuchModuleMember modName name) i InterfaceData iface deps -> do let mhash = _ifHash iface - dcDeps = mapMaybe (fmap DConst . preview _IfDConst) (_ifDefns iface) + dcDeps = mapMaybe ifDefToDef (_ifDefns iface) dconstDeps = M.fromList $ toDepMap mhash <$> dcDeps case M.lookup name dconstDeps of Just (nk, dk) -> do @@ -876,7 +871,7 @@ renameType i = \case resolveSchema = \case TBN bn -> view reCurrModule >>= \case - Just currM -> do + Just (currM,_) -> do rs <- use rsModuleBinds case rs ^? ix currM . ix (_bnName bn) of Just (_, DKDefSchema sc) -> pure sc @@ -1072,7 +1067,7 @@ renameDefCap => DefCap ParsedName DesugarType raw i -> m (DefCap Name Type raw i) renameDefCap (DefCap name arity argtys rtype term meta info) = do - meta' <- traverse resolveMeta meta + meta' <- resolveMeta meta argtys' <- (traverse.traverse) (renameType info) argtys rtype' <- traverse (renameType info) rtype term' <- local (set reCurrDef (Just DKDefCap) . bindArgs) $ renameTerm term @@ -1089,11 +1084,12 @@ renameDefCap (DefCap name arity argtys rtype term meta info) = do m = M.fromList $ zip (_argName <$> argtys) ((, Nothing) . NBound <$> ixs) in over reBinds (M.union m) $ set reVarDepth newDepth rEnv resolveMeta DefEvent = pure DefEvent - resolveMeta (DefManaged Nothing) = pure (DefManaged Nothing) - resolveMeta (DefManaged (Just (DefManagedMeta i (FQParsed pn)))) = do + resolveMeta Unmanaged = pure Unmanaged + resolveMeta (DefManaged AutoManagedMeta) = pure (DefManaged AutoManagedMeta) + resolveMeta (DefManaged (DefManagedMeta i (FQParsed pn))) = do (name', _) <- resolveName info pn fqn <- expectedFree info name' - pure (DefManaged (Just (DefManagedMeta i (FQName fqn)))) + pure (DefManaged (DefManagedMeta i (FQName fqn))) expectedFree :: MonadRenamer reso i m @@ -1129,6 +1125,7 @@ renameIfDef = \case rtype' <- traverse (renameType i) (_ifdRType d) pure (IfDfun (d{_ifdArgs = args', _ifdRType = rtype'})) IfDConst d -> IfDConst <$> renameDefConst d + IfDSchema d -> IfDSchema <$> renameDefSchema d IfDCap d -> do let i = _ifdcInfo d args' <- (traverse.traverse) (renameType i) (_ifdcArgs d) @@ -1179,13 +1176,17 @@ resolveBare (BareName bn) i = views reBinds (M.lookup bn) >>= \case Just (fqn, dk) -> pure (Name bn (NTopLevel (_fqModule fqn) (_fqHash fqn)), Just dk) Nothing -> do let mn = ModuleName bn Nothing - 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 + view reCurrModule >>= \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 resolveQualified :: (MonadRenamer b i m) @@ -1206,7 +1207,7 @@ renameModule :: (MonadDesugar raw reso i m) => Module ParsedName DesugarType raw i -> m (Module Name Type raw i) -renameModule (Module mname mgov defs blessed imp implements mhash i) = local (set reCurrModule (Just mname)) $ do +renameModule (Module mname mgov defs blessed imp implements mhash i) = local (set reCurrModule (Just (mname, implements))) $ do rsDependencies .= mempty mgov' <- resolveGov mgov let defNames = S.fromList $ fmap defName defs @@ -1223,7 +1224,7 @@ renameModule (Module mname mgov defs blessed imp implements mhash i) = local (se (defs'', _, _) <- over _1 reverse <$> foldlM go ([], S.empty, bindsWithImports) defs' let fqns = M.fromList $ (\d -> (defName d, (FullyQualifiedName mname (defName d) mhash, defKind d))) <$> defs'' rsLoaded . loToplevel %= M.union fqns - traverse_ (checkImplements i mname defs'') implements + traverse_ (checkImplements i defs'') implements pure (Module mname mgov' defs'' blessed imp implements mhash i) where handleImports binds [] = pure binds @@ -1274,26 +1275,26 @@ handleImport info binds (Import mn mh imported) = do checkImplements :: (MonadRenamer reso i m) => i - -> ModuleName -> [Def raw Type b i] -> ModuleName -> m () -checkImplements i mn defs ifaceName = +checkImplements i defs ifaceName = use (rsLoaded . loModules . at ifaceName) >>= \case Just (InterfaceData in' _depmap) -> traverse_ checkImplementedMember (_ifDefns in') -- Todo: lift into DesugarError (technically name resolution error but this is fine) - Just _ -> throwDesugarError (NoSuchInterface mn) i - Nothing -> view rePactDb >>= liftIO . (`readModule` mn) >>= \case + Just _ -> throwDesugarError (NoSuchInterface ifaceName) i + Nothing -> view rePactDb >>= liftIO . (`readModule` ifaceName) >>= \case Just (InterfaceData in' depmap) -> do loadInterface' in' depmap traverse_ checkImplementedMember (_ifDefns in') -- Todo: improve this error, could be "found module, expected interface" - Just _ -> throwDesugarError (NoSuchInterface mn) i - Nothing -> throwDesugarError (NoSuchInterface mn) i + Just _ -> throwDesugarError (NoSuchInterface ifaceName) i + Nothing -> throwDesugarError (NoSuchInterface ifaceName) i where checkImplementedMember = \case IfDConst{} -> pure () + IfDSchema{} -> pure () IfDfun ifd -> case find (\df -> _ifdName ifd == defName df) defs of Just (Dfun v) -> @@ -1313,7 +1314,7 @@ renameInterface :: (MonadDesugar raw reso i m) => Interface ParsedName DesugarType raw i -> m (Interface Name Type raw i) -renameInterface (Interface ifn defs ih info) = local (set reCurrModule (Just ifn)) $ do +renameInterface (Interface ifn defs ih info) = local (set reCurrModule (Just (ifn,[]))) $ do -- defMap = M.fromList $ (, (NTopLevel ifn ih, DKDefConst)) <$> rawDefNames -- fqns = M.fromList $ (\n -> (n, (FullyQualifiedName ifn n ih, DKDefConst))) <$> rawDefNames -- `maybe all of this next section should be in a block laid out by the @@ -1358,8 +1359,9 @@ reStateFromLoaded loaded = RenamerState mbinds loaded S.empty let depNames = (\def -> (defName def, (NTopLevel (_mName m) (_mHash m), defKind def))) <$> _mDefs m in M.fromList depNames InterfaceData iface _ -> - let depNames = _dcName <$> mapMaybe (preview _IfDConst) (_ifDefns iface) - in M.fromList $ (,(NTopLevel (_ifName iface) (_ifHash iface), DKDefConst)) <$> depNames + let deps = mapMaybe ifDefToDef (_ifDefns iface) + depNames = (\def -> (defName def, (NTopLevel (_ifName iface) (_ifHash iface), defKind def))) <$> deps + in M.fromList depNames mbinds = fmap mbind (_loModules loaded) loadedBinds :: Loaded b i -> Map Text (NameKind, DefKind) @@ -1416,7 +1418,7 @@ runDesugarReplDefun -> m (DesugarOutput reso i (Defun Name Type raw i)) runDesugarReplDefun _ pdb loaded = runDesugar' pdb loaded - . local (set reCurrModule (Just replModuleName)) + . local (set reCurrModule (Just (replModuleName, []))) . RenamerT . (desugarDefun >=> renameReplDefun) @@ -1429,7 +1431,7 @@ runDesugarReplDefConst -> m (DesugarOutput reso i (DefConst Name Type raw i)) runDesugarReplDefConst _ pdb loaded = runDesugar' pdb loaded - . local (set reCurrModule (Just replModuleName)) + . local (set reCurrModule (Just (replModuleName,[]))) . RenamerT . (desugarDefConst >=> renameReplDefConst) diff --git a/pact-core/Pact/Core/IR/Eval/CEK.hs b/pact-core/Pact/Core/IR/Eval/CEK.hs index e9f0c49b8..669ba4142 100644 --- a/pact-core/Pact/Core/IR/Eval/CEK.hs +++ b/pact-core/Pact/Core/IR/Eval/CEK.hs @@ -18,14 +18,16 @@ module Pact.Core.IR.Eval.CEK , requireCap , installCap , composeCap - , emitEvent , mkDefunClosure , enforceNotWithinDefcap , acquireModuleAdmin , isCapInStack , filterIndex , findMsgSigCap - , evalWithStackFrame) where + , evalWithStackFrame + , emitEvent + , emitCapability + , guardForModuleCall) where import Control.Lens hiding ((%%=)) import Control.Monad(zipWithM, unless, when) @@ -117,7 +119,7 @@ evalCEK cont handler env (Var n info) = do modRefHash <- _mHash <$> getModule info env (_mrModule mr) let nk = NTopLevel (_mrModule mr) modRefHash evalCEK cont handler env (Var (Name dArg nk) info) - Just _ -> returnCEK cont handler (VError "dynamic name pointed to non-modref") + Just _ -> returnCEK cont handler (VError "dynamic name pointed to non-modref" info) Nothing -> failInvariant info ("unbound identifier" <> T.pack (show n)) evalCEK cont handler _env (Constant l _) = do @@ -152,27 +154,30 @@ evalCEK cont handler env (Conditional c info) = case c of CIf cond e1 e2 -> evalCEK (CondC env info (IfFrame e1 e2) cont) handler env cond CEnforce cond str -> - evalCEK (CondC env info (EnforceFrame str) cont) handler env cond + let env' = sysOnlyEnv env + in evalCEK (CondC env' info (EnforceFrame str) cont) handler env' cond CEnforceOne str conds -> case conds of - [] -> returnCEK cont handler (VError "enforce-one failure") + [] -> returnCEK cont handler (VError "enforce-one failure" info) x:xs -> do cs <- useEvalState (esCaps . csSlots) - let handler' = CEKEnforceOne env info str xs cont cs handler - let cont' = CondC env info (EnforceOneFrame str xs) Mt - env' = readOnlyEnv env + let env' = readOnlyEnv env + let handler' = CEKEnforceOne env' info str xs cont cs handler + let cont' = CondC env' info (EnforceOneFrame str xs) Mt evalCEK cont' handler' env' x evalCEK cont handler env (CapabilityForm cf info) = do fqn <- nameToFQN info env (view capFormName cf) case cf of -- Todo: duplication here in the x:xs case - WithCapability _ args body -> case args of - x:xs -> do - let capFrame = WithCapFrame fqn body - let cont' = CapInvokeC env info xs [] capFrame cont - evalCEK cont' handler env x - [] -> evalCap info cont handler env (CapToken fqn []) body + WithCapability _ args body -> do + enforceNotWithinDefcap info env "with-capability" + case args of + x:xs -> do + let capFrame = WithCapFrame fqn body + let cont' = CapInvokeC env info xs [] capFrame cont + evalCEK cont' handler env x + [] -> evalCap info cont handler env (CapToken fqn []) (CapBodyC PopCapInvoke) body CreateUserGuard _ args -> case args of - [] -> createUserGuard cont handler fqn [] + [] -> createUserGuard info cont handler fqn [] x : xs -> let capFrame = CreateUserGuardFrame fqn cont' = CapInvokeC env info xs [] capFrame cont @@ -194,8 +199,8 @@ evalCEK cont handler env (ObjectLit o _) = evalCEK cont' handler env term [] -> returnCEKValue cont handler (VObject mempty) -- Error terms ignore the current cont -evalCEK _ handler _ (Error e _) = - returnCEK Mt handler (VError e) +evalCEK _ handler _ (Error e info) = + returnCEK Mt handler (VError e info) mkDefunClosure :: (MonadEval b i m) @@ -216,9 +221,10 @@ enforceKeyset => KeySet FullyQualifiedName -> m Bool enforceKeyset (KeySet kskeys ksPred) = do - allSigs <- viewCEKEnv eeMsgSigs - let matchedSigs = M.filterWithKey matchKey allSigs + matchedSigs <- M.filterWithKey matchKey <$> viewCEKEnv eeMsgSigs + -- liftIO $ print matchedSigs sigs <- checkSigCaps matchedSigs + -- liftIO $ print sigs runPred (M.size sigs) where matchKey k _ = k `elem` kskeys @@ -291,8 +297,8 @@ acquireModuleAdmin i env mdl = do CapGov (ResolvedGov fqn) -> do let wcapBody = Constant LUnit i -- *special* use of `evalCap` here to evaluate module governance. - evalCap i Mt CEKNoHandler (set ceLocal mempty env) (CapToken fqn []) wcapBody >>= \case - VError _ -> + evalCap i Mt CEKNoHandler (set ceLocal mempty env) (CapToken fqn []) (CapBodyC PopCapInvoke) wcapBody >>= \case + VError _ _ -> throwExecutionError i (ModuleGovernanceFailure (_mName mdl)) _ -> do esCaps . csModuleAdmin %%= S.insert (_mName mdl) @@ -308,8 +314,20 @@ evalWithStackFrame -> EvalTerm b i -> m (EvalResult b i m) evalWithStackFrame info cont handler env sf mty body = do + cont' <- pushStackFrame info cont mty sf + evalCEK cont' handler env body + +pushStackFrame + :: (MonadEval b i m) + => i + -> Cont b i m + -> Maybe Type + -> StackFrame + -> m (Cont b i m) +pushStackFrame info cont mty sf = do esStack %%= (sf :) - evalCEK (StackPopC info mty cont) handler env body + pure (StackPopC info mty cont) + -- | Evaluate a capability in `(with-capability)` -- the resulting @@ -322,29 +340,25 @@ evalCap -> CEKErrorHandler b i m -> CEKEnv b i m -> FQCapToken + -> (CEKEnv b i m -> Maybe (CapToken QualifiedName PactValue) -> Maybe (PactEvent PactValue) -> EvalTerm b i -> Cont b i m -> Cont b i m) -> EvalTerm b i -> m (EvalResult b i m) -evalCap info currCont handler env origToken@(CapToken fqn args) contbody = isCapInStack origToken >>= \case +evalCap info currCont handler env origToken@(CapToken fqn args) modCont contbody = isCapInStack origToken >>= \case False -> do - let qn = fqnToQualName fqn - let ct = CapToken qn args - enforceNotWithinDefcap info env "with-capability" lookupFqName fqn >>= \case Just (DCap d) -> do when (length args /= _dcapAppArity d) $ failInvariant info "Dcap argument length mismatch" - (esCaps . csSlots) %%= (CapSlot ct []:) - let env' = RAList.fromList $ fmap VPactValue (reverse args) + let newLocals = RAList.fromList $ fmap VPactValue (reverse args) capBody = _dcapTerm d - cont' = CapBodyC env contbody currCont -- Todo: clean up the staircase of doom. case _dcapMeta d of -- Managed capability, so we should look for it in the set of csmanaged - Just (DefManaged mdm) -> do + DefManaged mdm -> do case mdm of -- | Not automanaged, so it must have a defmeta -- We are handling user-managed caps - Just (DefManagedMeta cix _) -> do - let filteredCap = CapToken qn (filterIndex cix args) + DefManagedMeta cix _ -> do + let filteredCap = CapToken qualCapName (filterIndex cix args) -- Find the capability post-filtering mgdCaps <- useEvalState (esCaps . csManaged) case find ((==) filteredCap . _mcCap) mgdCaps of @@ -353,66 +367,105 @@ evalCap info currCont handler env origToken@(CapToken fqn args) contbody = isCap case find (findMsgSigCap cix filteredCap) msgCaps of Just c -> do let c' = set ctName fqn c - installCap info env c' >>= evalUserManagedCap cont' env' capBody + cont' = modCont env (Just qualCapToken) (Just (fqctToPactEvent origToken)) contbody currCont + installCap info env c' False >>= evalUserManagedCap cont' newLocals capBody Nothing -> throwExecutionError info (CapNotInstalled fqn) - Just managedCap -> evalUserManagedCap cont' env' capBody managedCap + Just managedCap -> do + let cont' = modCont env (Just qualCapToken) (Just (fqctToPactEvent origToken)) contbody currCont + evalUserManagedCap cont' newLocals capBody managedCap -- handle autonomous caps - Nothing -> do + AutoManagedMeta -> do -- Find the capability post-filtering + let cont' = modCont env Nothing (Just (fqctToPactEvent origToken)) contbody currCont mgdCaps <- useEvalState (esCaps . csManaged) - case find ((==) ct . _mcCap) mgdCaps of + case find ((==) qualCapToken . _mcCap) mgdCaps of Nothing -> do msgCaps <- S.unions <$> viewCEKEnv eeMsgSigs - case find ((==) ct) msgCaps of + case find ((==) qualCapToken) msgCaps of Just c -> do let c' = set ctName fqn c - installCap info env c' >>= evalAutomanagedCap cont' env' capBody + installCap info env c' False >>= evalAutomanagedCap cont' newLocals capBody Nothing -> throwExecutionError info (CapNotInstalled fqn) - Just managedCap -> case _mcManaged managedCap of - AutoManaged b -> do - if b then - returnCEK cont' handler (VError "automanaged capability used more than once") - else do - let newManaged = AutoManaged True - esCaps . csManaged %%= S.union (S.singleton (set mcManaged newManaged managedCap)) - evalWithStackFrame info cont' handler (set ceLocal env' env) capStackFrame Nothing capBody - _ -> failInvariant info "manager function mismatch" - Just DefEvent -> - failInvariant info "cannot evaluate the body of an event cap" - Nothing -> do - evalWithStackFrame info cont' handler (set ceLocal env' env) capStackFrame Nothing capBody + Just managedCap -> + evalAutomanagedCap cont' newLocals capBody managedCap + -- if b then + -- returnCEK cont' handler (VError "Automanaged capability used more than once" info) + -- else do + -- let newManaged = AutoManaged True + -- esCaps . csManaged %%= S.union (S.singleton (set mcManaged newManaged managedCap)) + -- (esCaps . csSlots) %%= (CapSlot qualCapToken []:) + -- sfCont <- pushStackFrame info cont' Nothing capStackFrame + -- emitCapability info origToken + -- evalCEK sfCont handler env capBody + -- evalWithStackFrame info cont' handler (set ceLocal env' env) capStackFrame Nothing capBody + -- _ -> failInvariant info "manager function mismatch" + DefEvent -> do + let cont' = modCont env Nothing (Just (fqctToPactEvent origToken)) contbody currCont + let inCapEnv = set ceInCap True $ set ceLocal newLocals env + (esCaps . csSlots) %%= (CapSlot qualCapToken []:) + sfCont <- pushStackFrame info cont' Nothing capStackFrame + -- emitCapability info origToken + evalCEK sfCont handler inCapEnv capBody + -- evalWithStackFrame info cont' handler (set ceLocal newLocals env) capStackFrame Nothing capBody + -- Not automanaged _nor_ user managed. + -- Todo: a type that's basically `Maybe` here would save us a lot of grief. + Unmanaged -> do + let cont' = modCont env Nothing Nothing contbody currCont + (esCaps . csSlots) %%= (CapSlot qualCapToken []:) + evalWithStackFrame info cont' handler (set ceLocal newLocals env) capStackFrame Nothing capBody Just {} -> failInvariant info "Captoken references invalid def" Nothing -> failInvariant info "No such def for evalCap" True -> evalCEK currCont handler env contbody where + qualCapName = fqnToQualName fqn + qualCapToken = CapToken qualCapName args capStackFrame = StackFrame (_fqName fqn) (_fqModule fqn) SFDefcap + -- This function is handles both evaluating the manager function for the installed parameter + -- and continuing evaluation for the actual capability body. + -- Todo: currently, pact does this _after_ evaluation of the cap body. Should we do this? evalUserManagedCap cont' env' capBody managedCap = case _mcManaged managedCap of ManagedParam mpfqn pv managedIx -> do lookupFqName mpfqn >>= \case + -- We found the manager function, evaluate it and commit the argument. Just (Dfun dfun) -> do mparam <- maybe (failInvariant def "Managed param does not exist at index") pure (args ^? ix managedIx) evaluate mpfqn (_dfunTerm dfun) pv mparam >>= \case EvalValue res -> do result <- enforcePactValue res let mcM = ManagedParam mpfqn result managedIx - esCaps . csManaged %%= S.union (S.singleton (set mcManaged mcM managedCap)) let inCapEnv = set ceInCap True $ set ceLocal env' $ env - evalWithStackFrame info cont' handler inCapEnv capStackFrame Nothing capBody - VError v -> returnCEK currCont handler (VError v) + let inCapBodyToken = _mcOriginalCap managedCap + -- BIG SEMANTICS NOTE HERE + -- the cap slot here that we push should NOT be the qualified original token. + -- Instead, it's the original token from the installed from the static cap. Otherwise, enforce checks + -- within the cap body will fail (That is, keyset enforcement). Instead, once we are evaluating the body, + -- we pop the current cap stack, then replace the head with the original intended token. + -- this is done in `CapBodyC` and this is the only way to do this. + esCaps . csManaged %%= S.union (S.singleton (set mcManaged mcM managedCap)) + (esCaps . csSlots) %%= (CapSlot inCapBodyToken []:) + sfCont <- pushStackFrame info cont' Nothing capStackFrame + -- emitCapability info origToken + evalCEK sfCont handler inCapEnv capBody + -- evalWithStackFrame info cont' handler inCapEnv capStackFrame Nothing capBody + VError v i -> returnCEK currCont handler (VError v i) _ -> failInvariant def "user managed cap is an invalid defn" _ -> failInvariant def "Invalid managed cap type" evalAutomanagedCap cont' env' capBody managedCap = case _mcManaged managedCap of AutoManaged b -> do - if b then returnCEK currCont handler (VError "automanaged cap used once") + if b then returnCEK currCont handler (VError "Automanaged capability used more than once" info) else do let newManaged = AutoManaged True esCaps . csManaged %%= S.union (S.singleton (set mcManaged newManaged managedCap)) + esCaps . csSlots %%= (CapSlot qualCapToken []:) let inCapEnv = set ceLocal env' $ set ceInCap True $ env - evalWithStackFrame info cont' handler inCapEnv capStackFrame Nothing capBody + sfCont <- pushStackFrame info cont' Nothing capStackFrame + -- emitCapability info origToken + evalCEK sfCont handler inCapEnv capBody + -- evalWithStackFrame info cont' handler inCapEnv capStackFrame Nothing capBody _ -> failInvariant def "Invalid managed cap type" evaluate fqn' term managed value = case term of Lam _ lamargs body i -> do @@ -425,6 +478,32 @@ evalCap info currCont handler env origToken@(CapToken fqn args) contbody = isCap applyLam (C clo) [VPactValue managed, VPactValue value] Mt CEKNoHandler _t -> failInvariant (view termInfo _t) "Manager function was not a two-argument function" +emitEvent + :: (MonadEval b i m) + => i + -> PactEvent PactValue + -> m () +emitEvent info pe = findCallingModule >>= \case + Just mn -> do + let ctModule = _peModule pe + if ctModule == mn then do + esEvents %%= (++ [pe]) + else throwExecutionError info (EventDoesNotMatchModule mn) + -- let fqn = _ctName ct + -- let ctModule = _fqModule fqn + Nothing -> failInvariant info "emit-event called outside of module code" + +emitCapability + :: (MonadEval b i m) + => i + -> CapToken FullyQualifiedName PactValue + -> m () +emitCapability info tkn = + emitEvent info (fqctToPactEvent tkn) + +fqctToPactEvent :: CapToken FullyQualifiedName PactValue -> PactEvent PactValue +fqctToPactEvent (CapToken fqn args) = PactEvent (_fqName fqn) args (_fqModule fqn) (_fqHash fqn) + enforceNotWithinDefcap :: (MonadEval b i m) => i @@ -436,14 +515,15 @@ enforceNotWithinDefcap info env form = requireCap :: MonadEval b i m - => Cont b i m + => i + -> Cont b i m -> CEKErrorHandler b i m -> FQCapToken -> m (EvalResult b i m) -requireCap cont handler ct@(CapToken fqn _) = do - capInStack <- isCapInStack ct +requireCap info cont handler ct@(CapToken fqn _) = do + capInStack <- isCapInStack ct if capInStack then returnCEKValue cont handler (VBool True) - else returnCEK cont handler $ VError $ "cap not in scope " <> renderQualName (fqnToQualName fqn) + else returnCEK cont handler $ VError ("cap not in scope " <> renderQualName (fqnToQualName fqn)) info isCapInStack :: (MonadEval b i m) @@ -451,9 +531,7 @@ isCapInStack -> m Bool isCapInStack (CapToken fqn args) = do let ct = CapToken (fqnToQualName fqn) args - caps <- useEvalState (esCaps.csSlots) - let csToSet cs = S.insert (_csCap cs) (S.fromList (_csComposed cs)) - capSet = foldMap csToSet caps + capSet <- getAllStackCaps pure $ S.member ct capSet composeCap @@ -464,22 +542,26 @@ composeCap -> CEKEnv b i m -> FQCapToken -> m (EvalResult b i m) -composeCap info cont handler env (CapToken fqn args) = do - let ct = CapToken (fqnToQualName fqn) args - lookupFqName fqn >>= \case - Just (DCap d) -> do - (esCaps . csSlots) %%= (CapSlot ct []:) - args' <- zipWithM (\pv arg -> maybeTCType info pv (_argType arg)) args (_dcapArgs d) - let env' = RAList.fromList $ fmap VPactValue (reverse args') - capBody = _dcapTerm d - let cont' = CapPopC PopCapComposed cont - evalCEK cont' handler (set ceLocal env' env) capBody - -- todo: this error loc is _not_ good. Need to propagate `i` here, maybe in the stack - Just d -> - throwExecutionError (defInfo d) $ InvalidDefKind (defKind d) "in compose-capability" - Nothing -> - -- Todo: error loc here - throwExecutionError' (NoSuchDef fqn) +composeCap info cont handler env origToken = + isCapInStack origToken >>= \case + False -> + evalCap info cont handler env origToken (CapBodyC PopCapComposed) (Constant (LBool True) info) + -- let ct = CapToken (fqnToQualName fqn) args + -- lookupFqName fqn >>= \case + -- Just (DCap d) -> do + -- (esCaps . csSlots) %%= (CapSlot ct []:) + -- args' <- zipWithM (\pv arg -> maybeTCType info pv (_argType arg)) args (_dcapArgs d) + -- let env' = RAList.fromList $ fmap VPactValue (reverse args') + -- capBody = _dcapTerm d + -- let cont' = UserGuardC (CapPopC PopCapComposed cont) + -- evalCEK cont' handler (set ceLocal env' env) capBody + -- -- todo: this error loc is _not_ good. Need to propagate `i` here, maybe in the stack + -- Just d -> + -- throwExecutionError (defInfo d) $ InvalidDefKind (defKind d) "in compose-capability" + -- Nothing -> + -- -- Todo: error loc here + -- throwExecutionError' (NoSuchDef fqn) + True -> returnCEKValue cont handler (VBool True) filterIndex :: Int -> [a] -> [a] filterIndex i xs = [x | (x, i') <- zip xs [0..], i /= i'] @@ -494,30 +576,32 @@ installCap :: (MonadEval b i m) => i -> CEKEnv b i m -> FQCapToken + -> Bool -> m (ManagedCap QualifiedName PactValue) -installCap info env (CapToken fqn args) = do - enforceNotWithinDefcap info env "install-capability" +installCap info _env (CapToken fqn args) autonomous = do let ct = CapToken (fqnToQualName fqn) args lookupFqName fqn >>= \case Just (DCap d) -> case _dcapMeta d of - Just (DefManaged m) -> case m of - Just (DefManagedMeta paramIx (FQName fqnMgr)) -> do + DefManaged m -> case m of + DefManagedMeta paramIx (FQName fqnMgr) -> do managedParam <- maybe (throwExecutionError info (InvalidManagedCap fqn)) pure (args ^? ix paramIx) let mcapType = ManagedParam fqnMgr managedParam paramIx ctFiltered = CapToken (fqnToQualName fqn) (filterIndex paramIx args) mcap = ManagedCap ctFiltered ct mcapType (esCaps . csManaged) %%= S.insert mcap - (esCaps . csAutonomous) %%= S.insert ct + when autonomous $ + (esCaps . csAutonomous) %%= S.insert ct pure mcap - Nothing -> do + AutoManagedMeta -> do let mcapType = AutoManaged False mcap = ManagedCap ct ct mcapType (esCaps . csManaged) %%= S.insert mcap - (esCaps . csAutonomous) %%= S.insert ct + when autonomous $ + (esCaps . csAutonomous) %%= S.insert ct pure mcap - Just DefEvent -> + DefEvent -> throwExecutionError info (InvalidManagedCap fqn) - Nothing -> throwExecutionError info (InvalidManagedCap fqn) + Unmanaged -> throwExecutionError info (InvalidManagedCap fqn) Just d -> -- todo: error loc here is not in install-cap throwExecutionError (defInfo d) (InvalidDefKind (defKind d) "install-capability") @@ -526,33 +610,22 @@ installCap info env (CapToken fqn args) = do -- Todo: should we typecheck / arity check here? createUserGuard :: (MonadEval b i m) - => Cont b i m + => i + -> Cont b i m -> CEKErrorHandler b i m -> FullyQualifiedName -> [PactValue] -> m (EvalResult b i m) -createUserGuard cont handler fqn args = +createUserGuard info cont handler fqn args = lookupFqName fqn >>= \case Just (Dfun _) -> returnCEKValue cont handler (VGuard (GUserGuard (UserGuard fqn args))) Just _ -> - returnCEK cont handler (VError "create-user-guard pointing to non-guard") + returnCEK cont handler (VError "create-user-guard pointing to non-guard" info) Nothing -> failInvariant def "User guard pointing to no defn" -emitEvent - :: MonadEval b i m - => Cont b i m - -> CEKErrorHandler b i m - -> FQCapToken - -> m (EvalResult b i m) -emitEvent cont handler ct@(CapToken fqn _) = do - let pactEvent = PactEvent ct (_fqModule fqn) (_fqHash fqn) - esEvents %%= (pactEvent:) - returnCEKValue cont handler VUnit - - returnCEK :: (MonadEval b i m) => Cont b i m @@ -590,7 +663,7 @@ returnCEK Mt handler v = VError{} -> case li of [] -> do setEvalState (esCaps . csSlots) cs - let cont' = EnforceErrorC cont + let cont' = EnforceErrorC i cont evalCEK cont' h env str x:xs -> do setEvalState (esCaps . csSlots) cs @@ -665,7 +738,7 @@ returnCEKValue (CondC env info frame cont) handler v = case v of EnforceFrame str -> if b then returnCEKValue cont handler v else do - let cont' = EnforceErrorC cont + let cont' = EnforceErrorC info cont evalCEK cont' handler env str EnforceOneFrame str li -> if b then returnCEKValue cont handler v @@ -675,7 +748,7 @@ returnCEKValue (CondC env info frame cont) handler v = case v of handler' = updateEnforceOneList xs handler evalCEK cont' handler' env x [] -> do - let cont' = EnforceErrorC cont + let cont' = EnforceErrorC info cont evalCEK cont' handler env str _ -> -- Todo: thread error loc here @@ -693,12 +766,22 @@ returnCEKValue (CapInvokeC env info terms pvs cf cont) handler v = do [] -> case cf of WithCapFrame fqn wcbody -> do guardForModuleCall info env (_fqModule fqn) $ return () - evalCap info cont handler env (CapToken fqn (reverse (pv:pvs))) wcbody + evalCap info cont handler env (CapToken fqn (reverse (pv:pvs))) (CapBodyC PopCapInvoke) wcbody CreateUserGuardFrame fqn -> - createUserGuard cont handler fqn (reverse (pv:pvs)) -returnCEKValue (CapBodyC env capbody cont) handler _ = do - let cont' = CapPopC PopCapInvoke cont - evalCEK cont' handler env capbody + createUserGuard info cont handler fqn (reverse (pv:pvs)) +returnCEKValue (CapBodyC cappop env mcap mevent capbody cont) handler _ = do + maybe (pure ()) (emitEvent def) mevent + case mcap of + Nothing -> do + let cont' = CapPopC cappop cont + evalCEK cont' handler env capbody + -- We're in a managed cap! We gotta do some quick stack manipulation. + Just cap -> useEvalState (esCaps . csSlots) >>= \case + (CapSlot _ tl:rest) -> do + setEvalState (esCaps . csSlots) (CapSlot cap tl:rest) + let cont' = CapPopC PopCapInvoke cont + evalCEK cont' handler env capbody + [] -> failInvariant def "In CapBodyC but with no caps in stack" returnCEKValue (CapPopC st cont) handler v = case st of PopCapInvoke -> do -- todo: need safe tail here, but this should be fine given the invariant that `CapPopC` @@ -728,9 +811,13 @@ returnCEKValue (ObjC env currfield fs vs cont) handler v = do in evalCEK cont' handler env term [] -> returnCEKValue cont handler (VObject (M.fromList (reverse fields))) -returnCEKValue (EnforceErrorC _) handler v = case v of - VString err -> returnCEK Mt handler (VError err) +returnCEKValue (EnforceErrorC info _) handler v = case v of + VString err -> returnCEK Mt handler (VError err info) _ -> failInvariant def "enforce function did not return a string" +-- Discard the value of running a user guard, no error occured, so +-- return true +returnCEKValue (UserGuardC cont) handler _v = + returnCEKValue cont handler (VBool True) returnCEKValue (StackPopC i mty cont) handler v = do v' <- (\pv -> maybeTCType i pv mty) =<< enforcePactValue v -- Todo: unsafe use of tail here. need `tailMay` diff --git a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs index ef32e28d6..4acbc1c60 100644 --- a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs +++ b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs @@ -22,7 +22,7 @@ module Pact.Core.IR.Eval.RawBuiltin -- CEK runtime for our IR term -- -import Control.Lens hiding (from, to, op, parts) +import Control.Lens hiding (from, to, op, parts, (%%=)) import Control.Monad(when, unless, foldM) import Control.Monad.IO.Class import Data.Containers.ListUtils(nubOrd) @@ -543,7 +543,7 @@ coreAccess = \info b cont handler _env -> \case Just v -> returnCEKValue cont handler (VPactValue v) Nothing -> let msg = "Object does not have field: " <> field - in returnCEK cont handler (VError msg) + in returnCEK cont handler (VError msg info) args -> argsError info b args ----------------------------------- @@ -591,13 +591,13 @@ coreEnforceGuard = \info b cont handler env -> \case GKeyset ks -> do cond <- enforceKeyset ks if cond then returnCEKValue cont handler (VBool True) - else returnCEK cont handler (VError "enforce keyset failure") + else returnCEK cont handler (VError "enforce keyset failure" info) GKeySetRef ksn -> do cond <- enforceKeysetName info env ksn if cond then returnCEKValue cont handler (VBool True) - else returnCEK cont handler (VError "enforce keyset failure") + else returnCEK cont handler (VError "enforce keyset ref failure" info) GUserGuard ug -> runUserGuard info cont handler env ug - GCapabilityGuard cg -> enforceCapGuard cont handler cg + GCapabilityGuard cg -> enforceCapGuard info cont handler cg GModuleGuard (ModuleGuard mn _) -> calledByModule mn >>= \case True -> returnCEKValue cont handler (VBool True) False -> do @@ -608,13 +608,16 @@ coreEnforceGuard = \info b cont handler env -> \case let ksn = KeySetName s cond <- enforceKeysetName info env ksn if cond then returnCEKValue cont handler (VBool True) - else returnCEK cont handler (VError "enforce keyset failure") + else returnCEK cont handler (VError "enforce keyset ref failure" info) args -> argsError info b args keysetRefGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -keysetRefGuard = \info b cont handler _env -> \case - [VString g] -> - returnCEKValue cont handler (VGuard (GKeySetRef (KeySetName g))) +keysetRefGuard = \info b cont handler env -> \case + [VString g] -> do + let pdb = view cePactDb env + liftDbFunction info (_pdbRead pdb DKeySets (KeySetName g)) >>= \case + Nothing -> returnCEK cont handler (VError ("no such keyset defined: " <> g) info) + Just _ -> returnCEKValue cont handler (VGuard (GKeySetRef (KeySetName g))) args -> argsError info b args coreReadInteger :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -623,7 +626,7 @@ coreReadInteger = \info b cont handler _env -> \case EnvData envData <- viewCEKEnv eeMsgBody case M.lookup (Field s) envData of Just (PInteger p) -> returnCEKValue cont handler (VInteger p) - _ -> returnCEK cont handler (VError "read-integer failure") + _ -> returnCEK cont handler (VError "read-integer failure" info) args -> argsError info b args readMsg :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -632,7 +635,7 @@ readMsg = \info b cont handler _env -> \case EnvData envData <- viewCEKEnv eeMsgBody case M.lookup (Field s) envData of Just pv -> returnCEKValue cont handler (VPactValue pv) - _ -> returnCEK cont handler (VError "read-integer failure") + _ -> returnCEK cont handler (VError "read-integer failure" info) [] -> do EnvData envData <- viewCEKEnv eeMsgBody returnCEKValue cont handler (VObject envData) @@ -644,7 +647,7 @@ coreReadDecimal = \info b cont handler _env -> \case EnvData envData <- viewCEKEnv eeMsgBody case M.lookup (Field s) envData of Just (PDecimal p) -> returnCEKValue cont handler (VDecimal p) - _ -> returnCEK cont handler (VError "read-integer failure") + _ -> returnCEK cont handler (VError "read-integer failure" info) args -> argsError info b args coreReadString :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -653,7 +656,7 @@ coreReadString = \info b cont handler _env -> \case EnvData envData <- viewCEKEnv eeMsgBody case M.lookup (Field s) envData of Just (PString p) -> returnCEKValue cont handler (VString p) - _ -> returnCEK cont handler (VError "read-integer failure") + _ -> returnCEK cont handler (VError "read-integer failure" info) args -> argsError info b args readKeyset' :: (MonadEval b i m) => T.Text -> m (Maybe (KeySet FullyQualifiedName)) @@ -690,24 +693,26 @@ coreReadKeyset = \info b cont handler _env -> \case [VString ksn] -> readKeyset' ksn >>= \case Just ks -> returnCEKValue cont handler (VGuard (GKeyset ks)) - Nothing -> returnCEK cont handler (VError "read-keyset failure") + Nothing -> returnCEK cont handler (VError "read-keyset failure" info) args -> argsError info b args enforceCapGuard :: MonadEval b i m - => Cont b i m + => i + -> Cont b i m -> CEKErrorHandler b i m -> CapabilityGuard FullyQualifiedName PactValue -> m (EvalResult b i m) -enforceCapGuard cont handler (CapabilityGuard fqn args) = do - let ct = CapToken (fqnToQualName fqn) args - caps <- useEvalState (esCaps.csSlots) - let csToSet cs = S.insert (_csCap cs) (S.fromList (_csComposed cs)) - capSet = foldMap csToSet caps - if S.member ct capSet then returnCEKValue cont handler VUnit +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) + returnCEK cont handler (VError errMsg info) runUserGuard :: MonadEval b i m @@ -723,10 +728,8 @@ runUserGuard info cont handler env (UserGuard fqn args) = when (length (_dfunArgs d) /= length args) $ throwExecutionError info CannotApplyPartialClosure let env' = sysOnlyEnv env clo <- mkDefunClosure d (_fqModule fqn) env' - -- clo <- ugTerm env' (_dfunTerm d) - -- clo = Closure (_dfunName d) (_fqModule fqn) cloargs (NE.length cloargs) (_dfunTerm d) (_dfunRType d) env' (_dfunInfo d) -- Todo: sys only here - applyLam (C clo) (VPactValue <$> args) cont handler + applyLam (C clo) (VPactValue <$> args) (UserGuardC cont) handler Just d -> throwExecutionError info (InvalidDefKind (defKind d) "run-user-guard") Nothing -> throwExecutionError info (NameNotInScope fqn) @@ -767,9 +770,9 @@ dbSelect = \info b cont handler env -> \case Just (RowData rdata) -> applyLam clo [VObject rdata] cont handler >>= \case EvalValue (VBool cond) -> if cond then go pdb ks (PObject rdata:acc) else go pdb ks acc - EvalValue _ -> returnCEK cont handler (VError "select query error") - VError e -> returnCEK cont handler (VError e) - Nothing -> returnCEK cont handler (VError "select is not enabled") + EvalValue _ -> returnCEK cont handler (VError "select query error" info) + VError e i -> returnCEK cont handler (VError e i) + Nothing -> returnCEK cont handler (VError "select is not enabled" info) args -> argsError info b args @@ -808,7 +811,7 @@ dbRead = \info b cont handler env -> \case guardTable info env tv liftDbFunction info (_pdbRead pdb (DUserTables (_tvName tv)) (RowKey k)) >>= \case Just (RowData v) -> returnCEKValue cont handler (VObject v) - Nothing -> returnCEK cont handler (VError "no such read object") + Nothing -> returnCEK cont handler (VError "no such read object" info) args -> argsError info b args dbWithRead :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -818,7 +821,7 @@ dbWithRead = \info b cont handler env -> \case guardTable info env tv liftDbFunction info (_pdbRead pdb (DUserTables (_tvName tv)) (RowKey k)) >>= \case Just (RowData v) -> applyLam clo [VObject v] cont handler - Nothing -> returnCEK cont handler (VError "no such read object") + Nothing -> returnCEK cont handler (VError "no such read object" info) args -> argsError info b args dbWithDefaultRead :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -848,7 +851,7 @@ write' wt = \info b cont handler env -> \case liftDbFunction info (_pdbWrite pdb wt (tvToDomain tv) (RowKey key) rowData) returnCEKValue cont handler (VString "Write succeeded") else - returnCEK cont handler (VError "object does not match schema") + returnCEK cont handler (VError "object does not match schema" info) args -> argsError info b args dbUpdate :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -860,7 +863,7 @@ dbUpdate = \info b cont handler env -> \case let rowData = RowData o liftDbFunction info (_pdbWrite pdb Update (tvToDomain tv) (RowKey key) rowData) returnCEKValue cont handler (VString "Write succeeded") - else returnCEK cont handler (VError "object does not match schema") + else returnCEK cont handler (VError "object does not match schema" info) args -> argsError info b args dbKeys :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -935,7 +938,7 @@ defineKeySet' info cont handler env ksname newKs = do if cond then do liftDbFunction info (_pdbWrite pdb Write DKeySets (KeySetName ksname) newKs) returnCEKValue cont handler (VString "Keyset write success") - else returnCEK cont handler (VError "enforce keyset failure") + else returnCEK cont handler (VError "enforce keyset failure" info) Nothing -> do liftDbFunction info (_pdbWrite pdb Write DKeySets (KeySetName ksname) newKs) returnCEKValue cont handler (VString "Keyset write success") @@ -948,7 +951,7 @@ defineKeySet = \info b cont handler env -> \case readKeyset' ksname >>= \case Just newKs -> defineKeySet' info cont handler env ksname newKs - Nothing -> returnCEK cont handler (VError "read-keyset failure") + Nothing -> returnCEK cont handler (VError "read-keyset failure" info) args -> argsError info b args -------------------------------------------------- @@ -957,7 +960,7 @@ defineKeySet = \info b cont handler env -> \case requireCapability :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m requireCapability = \info b cont handler _env -> \case - [VCapToken ct] -> requireCap cont handler ct + [VCapToken ct] -> requireCap info cont handler ct args -> argsError info b args composeCapability :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -974,13 +977,45 @@ installCapability :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m installCapability = \info b cont handler env -> \case [VCapToken ct] -> do enforceNotWithinDefcap info env "install-capability" - _ <- installCap info env ct - returnCEKValue cont handler VUnit + _ <- installCap info env ct True + returnCEKValue cont handler (VString "Installed capability") args -> argsError info b args +-- emitEvent +-- :: MonadEval b i m +-- => Cont b i m +-- -> CEKErrorHandler b i m +-- -> FQCapToken +-- -> m (EvalResult b i m) +-- emitEvent cont handler ct@(CapToken fqn _) = do +-- let pactEvent = PactEvent ct (_fqModule fqn) (_fqHash fqn) +-- esEvents %%= (pactEvent:) +-- returnCEKValue cont handler VUnit + coreEmitEvent :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -coreEmitEvent = \info b cont handler _env -> \case - [VCapToken ct] -> emitEvent cont handler ct +coreEmitEvent = \info b cont handler env -> \case + [VCapToken ct@(CapToken fqn _)] -> do + guardForModuleCall info env (_fqModule fqn) $ return () + lookupFqName (_ctName ct) >>= \case + Just (DCap d) -> do + enforceMeta (_dcapMeta d) + emitCapability info ct + returnCEKValue cont handler (VBool True) + Just _ -> + failInvariant info "CapToken does not point to defcap" + _ -> failInvariant info "No Capability found in emit-event" + where + enforceMeta Unmanaged = throwExecutionError info (InvalidEventCap fqn) + enforceMeta _ = pure () + -- Just mn -> do + -- let fqn = _ctName ct + -- let ctModule = _fqModule fqn + -- if ctModule == mn then do + -- let pactEvent = PactEvent ct (_fqModule fqn) (_fqHash fqn) + -- esEvents %%= (++ [pactEvent]) + -- returnCEKValue cont handler (VBool True) + -- else returnCEK cont handler (VError "Event does not match emitting module" info) + -- Nothing -> returnCEK cont handler (VError "emit-event called outside of module code" info) args -> argsError info b args createCapGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -998,7 +1033,7 @@ createModuleGuard = \info b cont handler _env -> \case let cg = GModuleGuard (ModuleGuard mn n) returnCEKValue cont handler (VGuard cg) Nothing -> - returnCEK cont handler (VError "not-in-module") + returnCEK cont handler (VError "not-in-module" info) args -> argsError info b args @@ -1011,8 +1046,8 @@ coreIntToStr = \info b cont handler _env -> \case | base == 64 && v >= 0 -> do let v' = toB64UrlUnpaddedText $ integerToBS v returnCEKValue cont handler (VString v') - | base == 64 -> returnCEK cont handler (VError "only positive values allowed for base64URL conversion") - | otherwise -> returnCEK cont handler (VError "invalid base for base64URL conversion") + | base == 64 -> returnCEK cont handler (VError "only positive values allowed for base64URL conversion" info) + | otherwise -> returnCEK cont handler (VError "invalid base for base64URL conversion" info) args -> argsError info b args coreStrToInt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -1042,7 +1077,7 @@ coreFormat = \info b cont handler _env -> \case let parts = T.splitOn "{}" s plen = length parts if | plen == 1 -> returnCEKValue cont handler (VString s) - | plen - length es > 1 -> returnCEK cont handler $ VError $ "format: not enough arguments for template" + | plen - length es > 1 -> returnCEK cont handler $ VError "format: not enough arguments for template" info | otherwise -> do let args = formatArg <$> V.toList es returnCEKValue cont handler $ VString $ T.concat $ alternate parts (take (plen - 1) args) @@ -1059,15 +1094,6 @@ coreFormat = \info b cont handler _env -> \case -- THIS CANNOT MAKE IT TO PROD renderPactValue :: PactValue -> T.Text renderPactValue = T.pack . show . Pretty.pretty - -- PLiteral l -> case l of - -- LString s -> "\"" <> s <> "\"" - -- LInteger i -> T.pack (show i) - -- LDecimal d -> T.pack (show d) - -- LUnit -> "()" - - - - checkLen :: (MonadEval b i m) @@ -1126,13 +1152,13 @@ coreAndQ = \info b cont handler _env -> \case EvalValue (VBool out) | out -> applyLam r [e] Mt CEKNoHandler >>= \case EvalValue (VBool out') -> returnCEKValue cont handler (VBool out') - VError err -> returnCEK cont handler (VError err) + VError err i -> returnCEK cont handler (VError err i) _ -> returnCEK cont handler invalidCloValue | otherwise -> returnCEKValue cont handler (VBool out) EvalValue _ -> returnCEK cont handler invalidCloValue - VError err -> returnCEK cont handler (VError err) + VError err i -> returnCEK cont handler (VError err i) where - invalidCloValue = VError "invalid return application for and? closure" + invalidCloValue = VError "invalid return application for and? closure" info args -> argsError info b args coreOrQ :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -1143,12 +1169,12 @@ coreOrQ = \info b cont handler _env -> \case | out -> returnCEKValue cont handler (VBool out) | otherwise -> applyLam r [e] Mt CEKNoHandler >>= \case EvalValue (VBool out') -> returnCEKValue cont handler (VBool out') - VError err -> returnCEK cont handler (VError err) + VError err i -> returnCEK cont handler (VError err i) _ -> returnCEK cont handler invalidCloValue EvalValue _ -> returnCEK cont handler invalidCloValue - VError err -> returnCEK cont handler (VError err) + VError err i -> returnCEK cont handler (VError err i) where - invalidCloValue = VError "invalid return application for and? closure" + invalidCloValue = VError "invalid return application for and? closure" info args -> argsError info b args coreNotQ :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -1157,9 +1183,9 @@ coreNotQ = \info b cont handler _env -> \case applyLam l [e] Mt CEKNoHandler >>= \case EvalValue (VBool out) -> returnCEKValue cont handler (VBool (not out)) EvalValue _ -> returnCEK cont handler invalidCloValue - VError err -> returnCEK cont handler (VError err) + VError err i -> returnCEK cont handler (VError err i) where - invalidCloValue = VError "invalid return application for and? closure" + invalidCloValue = VError "invalid return application for and? closure" info args -> argsError info b args coreWhere :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -1168,9 +1194,9 @@ coreWhere = \info b cont handler _env -> \case case M.lookup (Field field) o of Just v -> applyLam app [VPactValue v] Mt CEKNoHandler >>= \case EvalValue (VBool cond) -> returnCEKValue cont handler (VBool cond) - EvalValue _ -> returnCEK cont handler (VError "where application did not result in a boolean") - VError err -> returnCEK cont handler (VError err) - Nothing -> returnCEK cont handler (VError "no such field in object in where application") + EvalValue _ -> returnCEK cont handler (VError "where application did not result in a boolean" info) + VError err i -> returnCEK cont handler (VError err i) + Nothing -> returnCEK cont handler (VError "no such field in object in where application" info) args -> argsError info b args coreHash :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m @@ -1186,8 +1212,32 @@ txHash = \info b cont handler _env -> \case returnCEKValue cont handler (VString (hashToText h)) args -> argsError info b args +describeModule :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +describeModule = \info b cont handler env -> \case + [VString s] -> + getModuleData info env (ModuleName s Nothing) >>= \case + ModuleData m _ -> returnCEKValue cont handler $ + VObject $ M.fromList $ fmap (over _1 Field) + [ ("name", PString (renderModuleName (_mName m))) + , ("hash", PString (hashToText (_mhHash (_mHash m)))) + , ("interfaces", PList (PString . renderModuleName <$> V.fromList (_mImplements m)))] + InterfaceData iface _ -> returnCEKValue cont handler $ + VObject $ M.fromList $ fmap (over _1 Field) + [ ("name", PString (renderModuleName (_ifName iface))) + ] + args -> argsError info b args + +coreCompose :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreCompose = \info b cont handler _env -> \case + [VClosure clo1, VClosure clo2, v] -> + applyLam clo1 [v] Mt CEKNoHandler >>= \case + EvalValue v' -> + applyLam clo2 [v'] cont handler + err -> returnCEK cont handler err + args -> argsError info b args + ----------------------------------- --- Core definiti ons +-- Core definitions ----------------------------------- unimplemented :: NativeFunction b i m @@ -1276,7 +1326,7 @@ rawBuiltinRuntime = \case RawEmitEvent -> coreEmitEvent RawCreateTable -> createTable RawDescribeKeyset -> unimplemented - RawDescribeModule -> unimplemented + RawDescribeModule -> describeModule RawDescribeTable -> unimplemented RawDefineKeySet -> defineKeySet RawDefineKeysetData -> defineKeySet @@ -1298,4 +1348,5 @@ rawBuiltinRuntime = \case RawNotQ -> coreNotQ RawHash -> coreHash RawTxHash -> txHash + RawCompose -> coreCompose diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs index 7b345086c..ef26d2e61 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs @@ -250,7 +250,7 @@ pattern VPartialClosure clo = VClosure (PC clo) -- | Result of an evaluation step, either a CEK value or an error. data EvalResult b i m = EvalValue (CEKValue b i m) - | VError Text + | VError Text i deriving Show @@ -366,10 +366,17 @@ data Cont b i m -- ^ Continuation for the current object field being evaluated, and the already evaluated pairs | CapInvokeC (CEKEnv b i m) i [EvalTerm b i] [PactValue] (CapFrame b i) (Cont b i m) -- ^ Capability special form frams that eva - | CapBodyC (CEKEnv b i m) (EvalTerm b i) (Cont b i m) + | CapBodyC CapPopState (CEKEnv b i m) (Maybe (CapToken QualifiedName PactValue)) (Maybe (PactEvent PactValue)) (EvalTerm b i) (Cont b i m) + -- ^ CapBodyC includes + -- - what to do after the cap body (pop it, or compose it) + -- - Is it a user managed cap? If so, include the body token + -- - the capability "user body" to evaluate, generally carrying a series of expressions + -- or a simple return value in the case of `compose-capability` + -- - The rest of the continuation | CapPopC CapPopState (Cont b i m) + | UserGuardC (Cont b i m) | StackPopC i (Maybe Type) (Cont b i m) - | EnforceErrorC (Cont b i m) + | EnforceErrorC i (Cont b i m) | Mt -- ^ Empty Continuation deriving Show diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs index f056a4845..3a2472434 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs @@ -24,7 +24,7 @@ module Pact.Core.IR.Eval.Runtime.Utils , typecheckArgument , maybeTCType , safeTail - , toArgTypeError + , toArgTypeError , asString , asBool , throwExecutionError @@ -39,6 +39,7 @@ module Pact.Core.IR.Eval.Runtime.Utils , viewsCEKEnv , calledByModule , failInvariant + , getModuleData ) where import Control.Lens hiding ((%%=)) @@ -47,7 +48,7 @@ import Data.Map.Strict(Map) import Data.Text(Text) import Data.Set(Set) import Data.Default(def) -import Data.Maybe(listToMaybe) +import Data.Maybe(listToMaybe, mapMaybe) import Data.Foldable(find) import qualified Data.Map.Strict as M import qualified Data.Set as Set @@ -103,6 +104,8 @@ checkSigCaps checkSigCaps sigs = do granted <- getAllStackCaps autos <- useEvalState (esCaps . csAutonomous) + -- liftIO $ print granted + -- liftIO $ print sigs pure $ M.filter (match (Set.null autos) granted) sigs where match allowEmpty granted sigCaps = @@ -199,7 +202,7 @@ getCallingModule info = findCallingModule >>= \case failInvariant info "getCallingModule points to interface" Nothing -> failInvariant info "getCallingModule points to no loaded module" - Nothing -> error "no calling module in stack" + Nothing -> failInvariant info "Error: No Module in stack" toFqDep :: ModuleName -> ModuleHash -> Def name t b i -> (FullyQualifiedName, Def name t b i) toFqDep modName mhash defn = @@ -225,6 +228,27 @@ getModule info env mn = Nothing -> throwExecutionError info (ModuleDoesNotExist mn) +getModuleData :: (MonadEval b i m) => i -> CEKEnv b i m -> ModuleName -> m (ModuleData b i) +getModuleData info env mn = + useEvalState (esLoaded . loModules . at mn) >>= \case + Just md -> pure md + Nothing -> do + let pdb = view cePactDb env + liftDbFunction info (_pdbRead pdb DModules mn) >>= \case + Just mdata@(ModuleData md deps) -> do + let newLoaded = M.fromList $ toFqDep mn (_mHash md) <$> (_mDefs md) + (esLoaded . loAllLoaded) %%= M.union newLoaded . M.union deps + (esLoaded . loModules) %%= M.insert mn mdata + pure mdata + Just ifdata@(InterfaceData iface deps) -> do + let mdefs = mapMaybe ifDefToDef (_ifDefns iface) + let newLoaded = M.fromList $ toFqDep mn (_ifHash iface) <$> mdefs + (esLoaded . loAllLoaded) %%= M.union newLoaded . M.union deps + (esLoaded . loModules) %%= M.insert mn ifdata + pure ifdata + Nothing -> + throwExecutionError info (ModuleDoesNotExist mn) + safeTail :: [a] -> [a] safeTail (_:xs) = xs safeTail [] = [] @@ -276,7 +300,9 @@ throwExecutionError' :: (MonadEval b i m) => EvalError -> m a throwExecutionError' = throwExecutionError def readOnlyEnv :: CEKEnv b i m -> CEKEnv b i m -readOnlyEnv e = +readOnlyEnv e + | view (cePactDb . pdbPurity) e == PSysOnly = e + | otherwise = let pdb = view cePactDb e newPactdb = PactDb @@ -293,5 +319,29 @@ readOnlyEnv e = } in set cePactDb newPactdb e -sysOnlyEnv :: CEKEnv b i m -> CEKEnv b i m -sysOnlyEnv = set (cePactDb . pdbPurity) PSysOnly +sysOnlyEnv :: forall b i m. CEKEnv b i m -> CEKEnv b i m +sysOnlyEnv e + | view (cePactDb . pdbPurity) e == PSysOnly = e + | otherwise = + let newPactdb = + PactDb + { _pdbPurity = PSysOnly + , _pdbRead = read' + , _pdbWrite = \_ _ _ _ -> dbOpDisallowed + , _pdbKeys = \_ -> dbOpDisallowed + , _pdbCreateUserTable = \_ _ -> dbOpDisallowed + , _pdbBeginTx = \_ -> dbOpDisallowed + , _pdbCommitTx = dbOpDisallowed + , _pdbRollbackTx = dbOpDisallowed + , _pdbTxIds = \_ _ -> dbOpDisallowed + , _pdbGetTxLog = \_ _ -> dbOpDisallowed + } + in set cePactDb newPactdb e + where + pdb = view cePactDb e + read' :: Domain k v b i -> k -> IO (Maybe v) + read' dom k = case dom of + DUserTables _ -> dbOpDisallowed + DKeySets -> _pdbRead pdb DKeySets k + DModules -> _pdbRead pdb dom k + diff --git a/pact-core/Pact/Core/IR/Term.hs b/pact-core/Pact/Core/IR/Term.hs index b44109d91..be7a9c5c6 100644 --- a/pact-core/Pact/Core/IR/Term.hs +++ b/pact-core/Pact/Core/IR/Term.hs @@ -63,7 +63,7 @@ data DefCap name ty builtin info , _dcapArgs :: [Arg ty] , _dcapRType :: Maybe ty , _dcapTerm :: Term name ty builtin info - , _dcapMeta :: Maybe (DefCapMeta name) + , _dcapMeta :: DefCapMeta name , _dcapInfo :: info } deriving (Show, Functor) @@ -143,6 +143,7 @@ data IfDef name ty builtin info = IfDfun (IfDefun ty info) | IfDConst (DefConst name ty builtin info) | IfDCap (IfDefCap ty info) + | IfDSchema (DefSchema ty info) deriving (Show, Functor) data TopLevel name ty builtin info @@ -187,13 +188,14 @@ ifDefKind = \case IfDfun{} -> Nothing IfDCap{} -> Nothing IfDConst{} -> Just DKDefConst - + IfDSchema ds -> Just (DKDefSchema (Schema (_dsSchema ds))) ifDefName :: IfDef name ty builtin i -> Text ifDefName = \case IfDfun ifd -> _ifdName ifd IfDConst dc -> _dcName dc IfDCap ifd -> _ifdcName ifd + IfDSchema dc -> _dsName dc defInfo :: Def name ty b i -> i defInfo = \case @@ -203,12 +205,19 @@ defInfo = \case DSchema dc -> _dsInfo dc DTable dt -> _dtInfo dt +ifDefToDef :: IfDef name ty b i -> Maybe (Def name ty b i) +ifDefToDef = \case + IfDfun _ -> Nothing + IfDConst dc -> Just (DConst dc) + IfDCap _ -> Nothing + IfDSchema dc -> Just (DSchema dc) ifDefInfo :: IfDef name ty b i -> i ifDefInfo = \case IfDfun de -> _ifdInfo de IfDConst dc -> _dcInfo dc IfDCap d -> _ifdcInfo d + IfDSchema d -> _dsInfo d type EvalTerm b i = Term Name Type b i type EvalDef b i = Def Name Type b i diff --git a/pact-core/Pact/Core/Names.hs b/pact-core/Pact/Core/Names.hs index abb2cad8e..dcd1c1cb1 100644 --- a/pact-core/Pact/Core/Names.hs +++ b/pact-core/Pact/Core/Names.hs @@ -224,6 +224,17 @@ data FullyQualifiedName , _fqHash :: ModuleHash } deriving (Eq, Show, Ord) +fqnToName :: FullyQualifiedName -> Name +fqnToName (FullyQualifiedName mn name mh) = + Name name (NTopLevel mn mh) + +fqnToQualName :: FullyQualifiedName -> QualifiedName +fqnToQualName (FullyQualifiedName mn name _) = + QualifiedName name mn + +instance Pretty FullyQualifiedName where + pretty fq = pretty $ fqnToQualName fq + data TypeVar = TypeVar { _tyVarName :: !Text @@ -295,14 +306,6 @@ replModuleName = ModuleName replRawModuleName Nothing replModuleHash :: ModuleHash replModuleHash = ModuleHash (Hash "#repl") -fqnToName :: FullyQualifiedName -> Name -fqnToName (FullyQualifiedName mn name mh) = - Name name (NTopLevel mn mh) - -fqnToQualName :: FullyQualifiedName -> QualifiedName -fqnToQualName (FullyQualifiedName mn name _) = - QualifiedName name mn - renderFullyQualName :: FullyQualifiedName -> Text renderFullyQualName (FullyQualifiedName mn n _) = renderQualName (QualifiedName n mn) diff --git a/pact-core/Pact/Core/PactValue.hs b/pact-core/Pact/Core/PactValue.hs index 10c651eb3..48a161280 100644 --- a/pact-core/Pact/Core/PactValue.hs +++ b/pact-core/Pact/Core/PactValue.hs @@ -62,8 +62,7 @@ instance Pretty PactValue where pretty = \case PLiteral lit -> pretty lit PList p -> Pretty.list (V.toList (pretty <$> p)) - PGuard _g -> "" - -- PTable tn _sc -> "table" <> braces (pretty tn) + PGuard g -> pretty g PObject o -> braces $ hsep $ punctuate comma (objPair <$> M.toList o) where diff --git a/pact-core/Pact/Core/Pretty.hs b/pact-core/Pact/Core/Pretty.hs index fe29f484a..d291a0c22 100644 --- a/pact-core/Pact/Core/Pretty.hs +++ b/pact-core/Pact/Core/Pretty.hs @@ -8,11 +8,17 @@ module Pact.Core.Pretty , renderText' , commaSep , commaSepNE +, commaBraces +, commaBrackets +, bracketsSep +, parensSep +, bracesSep +-- , prettyList ) where import Data.Text(Text) import Prettyprinter -import Prettyprinter as Pretty +import qualified Prettyprinter as Pretty import Prettyprinter.Render.String import Prettyprinter.Render.Text import Data.List(intersperse) @@ -38,3 +44,13 @@ commaSepNE = commaSep . NE.toList commaSep :: Pretty a => [a] -> Doc ann commaSep = Pretty.hsep . intersperse "," . fmap pretty +commaBraces, commaBrackets, bracketsSep, parensSep, bracesSep :: [Doc ann] -> Doc ann +commaBraces = encloseSep "{" "}" "," +commaBrackets = encloseSep "[" "]" "," +bracketsSep = brackets . sep +parensSep = parens . sep +bracesSep = braces . sep + +-- prettyList :: Pretty a => [a] -> Doc ann +-- prettyList = list . map pretty + diff --git a/pact-core/Pact/Core/Repl.hs b/pact-core/Pact/Core/Repl.hs index d5dce57db..f8950124e 100644 --- a/pact-core/Pact/Core/Repl.hs +++ b/pact-core/Pact/Core/Repl.hs @@ -46,6 +46,7 @@ import Pact.Core.PactValue import Pact.Core.Hash import Pact.Core.Capabilities import Pact.Core.Imports +import Pact.Core.Errors main :: IO () main = do @@ -93,19 +94,6 @@ main = do outputStrLn "Error: Expected command [:load, :type, :syntax, :debug] or expression" loop Just ra -> case ra of - RALoad txt -> let - file = T.unpack txt - in catch' $ do - source <- liftIO (B.readFile file) - eout <- lift $ tryError $ interpretReplProgram (SourceCode source) - case eout of - Right vs -> traverse_ displayOutput vs - Left err -> let - rs = ReplSource (T.pack file) (T.decodeUtf8 source) - in outputStrLn (T.unpack (replError rs err)) - loop - RASetLispSyntax -> loop - RASetNewSyntax -> loop RASetFlag flag -> do lift (replFlags %= Set.insert flag) outputStrLn $ unwords ["set debug flag for", prettyReplFlag flag] diff --git a/pact-core/Pact/Core/Repl/Compile.hs b/pact-core/Pact/Core/Repl/Compile.hs index e7b107460..d17ca228e 100644 --- a/pact-core/Pact/Core/Repl/Compile.hs +++ b/pact-core/Pact/Core/Repl/Compile.hs @@ -106,46 +106,49 @@ interpretReplProgram sc@(SourceCode source) = do pipe' tl = do pactdb <- use replPactDb debugIfLispExpr tl + _ <- moduleGov pactdb tl lastLoaded <- use loaded ds <- runDesugarReplTopLevel (Proxy @ReplRawBuiltin) pactdb lastLoaded tl debugIfIRExpr ReplDebugDesugar (_dsOut ds) loaded .= _dsLoaded ds interpret ds + + moduleGov pactdb (Lisp.RTLTopLevel tl) = + () <$ evalModuleGovernance pactdb interpreter tl + moduleGov _ _ = pure () + + interpreter = Interpreter $ \te -> do + evalGas <- use replGas + evalLog <- use replEvalLog + es <- use replEvalState + tx <- use replTx + ee <- use replEvalEnv + -- todo: cache? + -- mhashes <- uses (loaded . loModules) (fmap (view mdModuleHash)) + let rEnv = ReplEvalEnv evalGas evalLog replBuiltinEnv + rState = ReplEvalState ee es sc tx + (out, st) <- liftIO (runReplCEK rEnv rState te) + replTx .= view reTx st + evalState .= view reState st + replEvalEnv .= view reEnv st + liftEither out >>= \case + VError txt _ -> + throwError (PEExecutionError (EvalError txt) (view termInfo te)) + EvalValue v -> do + loaded .= view (reState . esLoaded) st + case v of + VClosure{} -> do + pure IPClosure + VTable tv -> pure (IPTable (_tvName tv)) + VPactValue pv -> do + pure (IPV pv (view termInfo te)) interpret (DesugarOutput tl _ deps) = do pdb <- use replPactDb lo <- use loaded - ee <- use replEvalEnv case tl of RTLTopLevel tt -> do - let interp = Interpreter interpreter - RCompileValue <$> interpretTopLevel pdb interp (DesugarOutput tt lo deps) + RCompileValue <$> interpretTopLevel pdb interpreter (DesugarOutput tt lo deps) where - -- interpreter :: EvalTerm (ReplBuiltin RawBuiltin) SpanInfo -> ReplM ReplRawBuiltin InterpretValue - interpreter te = do - let i = view termInfo te - evalGas <- use replGas - evalLog <- use replEvalLog - es <- use replEvalState - tx <- use replTx - -- todo: cache? - -- mhashes <- uses (loaded . loModules) (fmap (view mdModuleHash)) - let rEnv = ReplEvalEnv evalGas evalLog replBuiltinEnv - rState = ReplEvalState ee es sc tx - (out, st) <- liftIO (runReplCEK rEnv rState te) - replTx .= view reTx st - evalState .= view reState st - replEvalEnv .= view reEnv st - liftEither out >>= \case - VError txt -> - throwError (PEExecutionError (EvalError txt) i) - EvalValue v -> do - loaded .= view (reState . esLoaded) st - case v of - VClosure{} -> do - pure IPClosure - VTable tv -> pure (IPTable (_tvName tv)) - VPactValue pv -> do - pure (IPV pv (view termInfo te)) RTLDefun df -> do let fqn = FullyQualifiedName replModuleName (_dfunName df) replModuleHash loaded . loAllLoaded %= M.insert fqn (Dfun df) diff --git a/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs b/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs index 7fd23bfda..1300f0175 100644 --- a/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs +++ b/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs @@ -79,25 +79,31 @@ coreExpectThat = \info b cont handler _env -> \case EvalValue (VLiteral (LBool c)) -> if c then returnCEKValue cont handler (VLiteral (LString ("Expect-that: success " <> msg))) else returnCEKValue cont handler (VLiteral (LString ("FAILURE: Expect-that: Did not satisfy condition: " <> msg))) - EvalValue _ -> return (VError "Expect-that: condition did not return a boolean") - VError ve -> return (VError ve) + EvalValue _ -> return (VError "Expect-that: condition did not return a boolean" info) + VError ve i -> return (VError ve i) args -> argsError info b args coreExpectFailure :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) coreExpectFailure = \info b cont handler _env -> \case [VLiteral (LString toMatch), VClosure vclo] -> do + es <- getEvalState tryError (applyLam vclo [] Mt CEKNoHandler) >>= \case - Right (VError _e) -> + Right (VError _ _) -> do + putEvalState es returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> toMatch Left _err -> do + putEvalState es returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> toMatch Right _ -> returnCEKValue cont handler $ VLiteral $ LString $ "FAILURE: " <> toMatch <> ": expected failure, got result" [VString desc, VString toMatch, VClosure vclo] -> do + es <- getEvalState tryError (applyLam vclo [] Mt CEKNoHandler) >>= \case - Right (VError _e) -> + Right (VError _ _) -> do + putEvalState es returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> desc Left _err -> do + putEvalState es returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> desc Right _ -> returnCEKValue cont handler $ VLiteral $ LString $ "FAILURE: " <> toMatch <> ": expected failure, got result" @@ -106,24 +112,31 @@ coreExpectFailure = \info b cont handler _env -> \case coreEnvStackFrame :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) coreEnvStackFrame = \info b cont handler _env -> \case [] -> do - frames <- useEvalState esStack - liftIO $ print frames - returnCEKValue cont handler VUnit + capSet <- getAllStackCaps + returnCEKValue cont handler $ VString $ T.pack (show capSet) args -> argsError info b args envEvents :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) envEvents = \info b cont handler _env -> \case - [] -> do - events <- useEvalState esEvents - liftIO $ print events - returnCEKValue cont handler VUnit + [VBool clear] -> do + events <- fmap envToObj <$> useEvalState esEvents + when clear $ setEvalState esEvents [] + returnCEKValue cont handler (VList (V.fromList events)) + where + envToObj (PactEvent name args mn mh) = + PObject + $ M.fromList + $ fmap (over _1 Field) + $ [ ("name", PString (renderQualName (QualifiedName name mn))) + , ("params", PList (V.fromList args)) + , ("module-hash", PString (hashToText (_mhHash mh)))] args -> argsError info b args envHash :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) envHash = \info b cont handler _env -> \case [VString s] -> do case decodeBase64UrlUnpadded (T.encodeUtf8 s) of - Left e -> returnCEK cont handler (VError (T.pack e)) + Left e -> returnCEK cont handler (VError (T.pack e) info) Right hs -> do (reEnv . eeHash) .= Hash (toShort hs) returnCEKValue cont handler VUnit @@ -162,7 +175,7 @@ envChainData = \info b cont handler _env -> \case go (set (pdPublicMeta . pmSender) s pd) rest | k == cdPrevBlockHash -> go (set pdPrevBlockHash s pd) rest - _ -> returnCEK cont handler (VError $ "envChainData: bad public metadata value for key: " <> _field k) + _ -> returnCEK cont handler (VError ("envChainData: bad public metadata value for key: " <> _field k) info) args -> argsError info b args envKeys :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) @@ -180,7 +193,7 @@ envSigs = \info b cont handler _env -> \case Just sigs -> do (reEnv . eeMsgSigs) .= M.fromList (V.toList sigs) returnCEKValue cont handler VUnit - Nothing -> returnCEK cont handler (VError "env-sigs format is wrong") + Nothing -> returnCEK cont handler (VError ("env-sigs format is wrong") info) where keyCapObj = \case PObject o -> do @@ -196,14 +209,14 @@ envSigs = \info b cont handler _env -> \case beginTx :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) beginTx = \info b cont handler _env -> \case - [VString s] -> begin' info (Just s) >>= returnCEK cont handler . renderTx "Begin Tx" - [] -> begin' info Nothing >>= returnCEK cont handler . renderTx "Begin Tx" + [VString s] -> begin' info (Just s) >>= returnCEK cont handler . renderTx info "Begin Tx" + [] -> begin' info Nothing >>= returnCEK cont handler . renderTx info "Begin Tx" args -> argsError info b args -renderTx :: Text -> Maybe (TxId, Maybe Text) -> EvalResult b i m -renderTx start (Just (TxId tid, mt)) = +renderTx :: i -> Text -> Maybe (TxId, Maybe Text) -> EvalResult b i m +renderTx _info start (Just (TxId tid, mt)) = EvalValue $ VString $ start <> " " <> T.pack (show tid) <> maybe mempty ((<>) " ") mt -renderTx start Nothing = VError $ "tx-function failure " <> start +renderTx info start Nothing = VError ("tx-function failure " <> start) info begin' :: (Default i) => i -> Maybe Text -> ReplEvalM b i (Maybe (TxId, Maybe Text)) begin' info mt = do @@ -222,8 +235,8 @@ commitTx = \info b cont handler _env -> \case use reTx >>= \case Just tx -> do reTx .= Nothing - returnCEK cont handler (renderTx "Commit Tx" (Just tx)) - Nothing -> returnCEK cont handler (renderTx "Commit Tx" Nothing) + returnCEK cont handler (renderTx info "Commit Tx" (Just tx)) + Nothing -> returnCEK cont handler (renderTx info "Commit Tx" Nothing) args -> argsError info b args @@ -236,8 +249,8 @@ rollbackTx = \info b cont handler _env -> \case use reTx >>= \case Just tx -> do reTx .= Nothing - returnCEK cont handler (renderTx "Rollback Tx" (Just tx)) - Nothing -> returnCEK cont handler (renderTx "Rollback Tx" Nothing) + returnCEK cont handler (renderTx info "Rollback Tx" (Just tx)) + Nothing -> returnCEK cont handler (renderTx info "Rollback Tx" Nothing) args -> argsError info b args sigKeyset :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) @@ -249,105 +262,23 @@ sigKeyset = \info b cont handler _env -> \case testCapability :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) -testCapability = \info b currCont handler env -> \case - [VCapToken origToken@(CapToken fqn args)] -> isCapInStack origToken >>= \case - False -> do - let qn = fqnToQualName fqn - let ct = CapToken qn args - lookupFqName fqn >>= \case - Just (DCap d) -> do - when (length args /= _dcapAppArity d) $ failInvariant info "Dcap argument length mismatch" - (esCaps . csSlots) %%= (CapSlot ct []:) - let env' = RAList.fromList $ fmap VPactValue (reverse args) - capBody = _dcapTerm d - -- Todo: clean up the staircase of doom. - case _dcapMeta d of - -- Managed capability, so we should look for it in the set of csmanaged - Just (DefManaged mdm) -> do - case mdm of - -- | Not automanaged, so it must have a defmeta - -- We are handling user-managed caps - Just (DefManagedMeta cix _) -> do - let filteredCap = CapToken qn (filterIndex cix args) - -- Find the capability post-filtering - mgdCaps <- useEvalState (esCaps . csManaged) - case find ((==) filteredCap . _mcCap) mgdCaps of - Nothing -> do - msgCaps <- S.unions <$> viewCEKEnv eeMsgSigs - case find (findMsgSigCap cix filteredCap) msgCaps of - Just c -> do - let c' = set ctName fqn c - installCap info env c' >>= evalUserManagedCap currCont env' capBody - Nothing -> - throwExecutionError info (CapNotInstalled fqn) - Just managedCap -> evalUserManagedCap currCont env' capBody managedCap - -- handle autonomous caps - Nothing -> do - -- Find the capability post-filtering - mgdCaps <- useEvalState (esCaps . csManaged) - case find ((==) ct . _mcCap) mgdCaps of - Nothing -> do - msgCaps <- S.unions <$> viewCEKEnv eeMsgSigs - case find ((==) ct) msgCaps of - Just c -> do - let c' = set ctName fqn c - installCap info env c' >>= evalAutomanagedCap currCont env' capBody - Nothing -> - throwExecutionError info (CapNotInstalled fqn) - Just managedCap -> case _mcManaged managedCap of - AutoManaged bcond -> do - if bcond then - returnCEK currCont handler (VError "automanaged capability used more than once") - else do - let newManaged = AutoManaged True - esCaps . csManaged %%= S.union (S.singleton (set mcManaged newManaged managedCap)) - evalWithStackFrame info currCont handler (set ceLocal env' env) capStackFrame Nothing capBody - _ -> failInvariant info "manager function mismatch" - Just DefEvent -> - failInvariant info "cannot evaluate the body of an event cap" - Nothing -> do - evalWithStackFrame info currCont handler (set ceLocal env' env) capStackFrame Nothing capBody - Just {} -> - failInvariant info "Captoken references invalid def" - Nothing -> failInvariant info "No such def for evalCap" - True -> - returnCEKValue currCont handler (VString "Capability already acquired") - where - capStackFrame = StackFrame (_fqName fqn) (_fqModule fqn) SFDefcap - evalUserManagedCap cont' env' capBody managedCap = case _mcManaged managedCap of - ManagedParam mpfqn pv managedIx -> do - lookupFqName mpfqn >>= \case - Just (Dfun dfun) -> do - mparam <- maybe (failInvariant def "Managed param does not exist at index") pure (args ^? ix managedIx) - evaluate mpfqn (_dfunTerm dfun) pv mparam >>= \case - EvalValue res -> do - result <- enforcePactValue res - let mcM = ManagedParam mpfqn result managedIx - esCaps . csManaged %%= S.union (S.singleton (set mcManaged mcM managedCap)) - let inCapEnv = set ceInCap True $ set ceLocal env' $ env - evalWithStackFrame info cont' handler inCapEnv capStackFrame Nothing capBody - VError v -> returnCEK currCont handler (VError v) - _ -> failInvariant def "user managed cap is an invalid defn" - _ -> failInvariant def "Invalid managed cap type" - evalAutomanagedCap cont' env' capBody managedCap = case _mcManaged managedCap of - AutoManaged bcond -> do - if bcond then returnCEK currCont handler (VError "automanaged cap used once") - else do - let newManaged = AutoManaged True - esCaps . csManaged %%= S.union (S.singleton (set mcManaged newManaged managedCap)) - let inCapEnv = set ceLocal env' $ set ceInCap True $ env - evalWithStackFrame info cont' handler inCapEnv capStackFrame Nothing capBody - _ -> failInvariant def "Invalid managed cap type" - evaluate fqn' term managed value = case term of - Lam _ lamargs body i -> do - -- Todo: `applyLam` here gives suboptimal errors - -- Todo: this completely violates our "step" semantics. - -- This should be its own frame - let inCapEnv = set ceInCap True env - cloArgs = ArgClosure(_argType <$> lamargs) - clo = Closure (_fqName fqn') (_fqModule fqn') cloArgs (NE.length lamargs) body Nothing inCapEnv i - applyLam (C clo) [VPactValue managed, VPactValue value] Mt CEKNoHandler - _t -> failInvariant (view termInfo _t) "Manager function was not a two-argument function" +testCapability = \info b cont handler env -> \case + [VCapToken origToken] -> do + lookupFqName (_ctName origToken) >>= \case + Just (DCap d) -> do + let cBody = Constant LUnit info + ignoreContBody _env _mct _mev _cb c = c + cont' = SeqC env cBody cont + case _dcapMeta d of + Unmanaged -> + evalCap info cont' handler env origToken ignoreContBody cBody + _ -> do + -- Installed caps emit and event + -- so we create a fake stack frame + let sf = StackFrame "test-capability" (views ctName _fqModule origToken) SFDefun + esStack %%= (sf :) + installCap info env origToken False *> evalCap info cont' handler env origToken ignoreContBody cBody + _ -> returnCEK cont handler (VError "no such capability" info) args -> argsError info b args diff --git a/pact-core/Pact/Core/Repl/Utils.hs b/pact-core/Pact/Core/Repl/Utils.hs index 9896ec312..75bc462c4 100644 --- a/pact-core/Pact/Core/Repl/Utils.hs +++ b/pact-core/Pact/Core/Repl/Utils.hs @@ -138,11 +138,11 @@ instance HasLoaded (ReplState b) b SpanInfo where loaded = evalState . esLoaded data ReplAction - = RALoad Text - | RASetLispSyntax - | RASetNewSyntax + -- = RALoad Text + -- | RASetLispSyntax + -- | RASetNewSyntax -- | RATypecheck Text - | RASetFlag ReplDebugFlag + = RASetFlag ReplDebugFlag | RADebugAll | RADebugNone | RAExecuteExpr Text @@ -169,19 +169,19 @@ replAction = cmdKw kw = MP.chunk kw *> MP.space1 cmd = do _ <- MP.chunk ":" - load <|> setLang <|> setFlag "asdf" + setFlag "asdf" setFlag = cmdKw "debug" *> ((RASetFlag <$> replFlag) <|> (RADebugAll <$ MP.chunk "all") <|> (RADebugNone <$ MP.chunk "none")) - setLang = do - cmdKw "syntax" - (RASetLispSyntax <$ MP.chunk "lisp") <|> (RASetNewSyntax <$ MP.chunk "new") + -- setLang = do + -- cmdKw "syntax" + -- (RASetLispSyntax <$ MP.chunk "lisp") <|> (RASetNewSyntax <$ MP.chunk "new") -- tc = do -- cmdKw "type" -- RATypecheck <$> MP.takeRest - load = do - cmdKw "load" - let c = MP.char '\"' - RALoad <$> MP.between c c (MP.takeWhile1P Nothing (/= '\"')) + -- load = do + -- cmdKw "load" + -- let c = MP.char '\"' + -- RALoad <$> MP.between c c (MP.takeWhile1P Nothing (/= '\"')) parseReplAction :: Text -> Maybe ReplAction parseReplAction = MP.parseMaybe replAction @@ -272,7 +272,8 @@ replError replError (ReplSource file src) pe = let srcLines = T.lines src pei = view peInfo pe - slice = withLine (_liStartLine pei) $ take (max 1 (_liEndLine pei)) $ drop (_liStartLine pei) srcLines + end = _liEndLine pei - _liStartLine pei + slice = withLine (_liStartLine pei) $ take (max 1 end) $ drop (_liStartLine pei) srcLines colMarker = " | " <> T.replicate (_liStartColumn pei) " " <> T.replicate (max 1 (_liEndColumn pei - _liStartColumn pei)) "^" errRender = renderText pe fileErr = file <> ":" <> T.pack (show (_liStartLine pei + 1)) <> ":" <> T.pack (show (_liStartColumn pei)) <> ": " diff --git a/pact-core/Pact/Core/Syntax/Parser.y b/pact-core/Pact/Core/Syntax/Parser.y index 83fd62395..d1c9f92a0 100644 --- a/pact-core/Pact/Core/Syntax/Parser.y +++ b/pact-core/Pact/Core/Syntax/Parser.y @@ -134,7 +134,6 @@ ReplTopLevel :: { ParsedReplTopLevel } : TopLevel { RTLTopLevel $1 } | '(' Defun ')' { RTLDefun ($2 (combineSpan (_ptInfo $1) (_ptInfo $3))) } | '(' DefConst ')' { RTLDefConst ($2 (combineSpan (_ptInfo $1) (_ptInfo $3))) } - | Expr { RTLTerm $1 } ReplSpecial :: { SpanInfo -> ReplSpecialForm SpanInfo }