Merge branch 'master' into jose/namespaces

pact-core-tests/Pact/Core/Test/ReplTests.hs

@@ -49,19 +49,20 @@ runReplTest file src = do
   gasRef <- newIORef (Gas 0)
   gasLog <- newIORef Nothing
   pdb <- mockPactDb
-  let ee = EvalEnv mempty pdb (EnvData mempty) (Hash "default") def Nothing Transactional mempty
+  let ee = EvalEnv mempty pdb (EnvData mempty) defaultPactHash def Nothing Transactional mempty
+      source = SourceCode (takeFileName file) src
   let rstate = ReplState
             { _replFlags =  mempty
             , _replEvalState = def
             , _replPactDb = pdb
             , _replGas = gasRef
             , _replEvalLog = gasLog
-            , _replCurrSource = SourceCode mempty
+            , _replCurrSource = source
             , _replEvalEnv = ee
             , _replTx = Nothing
             }
   stateRef <- newIORef rstate
-  runReplT stateRef (interpretReplProgram (SourceCode src) (const (pure ()))) >>= \case
+  runReplT stateRef (interpretReplProgram source (const (pure ()))) >>= \case
     Left e -> let
       rendered = replError (ReplSource (T.pack file) (decodeUtf8 src)) e
       in assertFailure (T.unpack rendered)

pact-core-tests/pact-tests/caps.repl

@@ -798,12 +798,12 @@
   (defun test-cap-guard (n:string m:string)
     (with-capability (CAP1 n)
       (enforce-guard (create-capability-guard (CAP1 m)))))
-  ;  (defpact cg-pact (kw:string kr:string n:string m:string)
-  ;    (step (write cg-tbl kw { 'g: (create-capability-pact-guard (CAP1 m)) }))
-  ;    (step
-  ;     (with-read cg-tbl kr { 'g := cg }
-  ;      (with-capability (CAP1 n) (enforce-guard cg))))
-  ;  )
+  (defpact cg-pact (kw:string kr:string n:string m:string)
+    (step (write cg-tbl kw { 'g: (create-capability-pact-guard (CAP1 m)) }))
+    (step
+     (with-read cg-tbl kr { 'g := cg }
+      (with-capability (CAP1 n) (enforce-guard cg))))
+  )
 )
 (create-table cg-tbl)
 
@@ -817,35 +817,34 @@
  "Capability not acquired"
  (test-cap-guard "A" "B"))
 
-;  (env-hash (hash 1))
+(env-hash (hash 1))
 
-;  (cg-pact 'k1 'k1 "C" "C")
-;  (expect
-;   "cap pact guard succeeds"
-;   true
-;   (continue-pact 1))
+(cg-pact 'k1 'k1 "C" "C")
+(expect
+ "cap pact guard succeeds"
+ true
+ (continue-pact 1))
 
-;  (pact-state true)
-;  (env-hash (hash 2))
+(pact-state true)
+(env-hash (hash 2))
 
-;  (cg-pact 'k2 'k2 "D" "E")
-;  (expect-failure
-;   "cap pact guard fails on wrong cap"
-;   "Capability not acquired"
-;   (continue-pact 1))
+(cg-pact 'k2 'k2 "D" "E")
+(expect-failure
+ "cap pact guard fails on wrong cap"
+ "Capability not acquired"
+ (continue-pact 1))
 
-;  (pact-state true)
-;  (env-hash (hash 3))
+(pact-state true)
+(env-hash (hash 3))
 
-;  (cg-pact 'k3 'k1 "C" "C")
-;  (expect-failure
-;   "cap pact guard fails on wrong pact id"
-;   "Invalid Pact ID"
-;   (continue-pact 1))
+(cg-pact 'k3 'k1 "C" "C")
+(expect-failure
+ "cap pact guard fails on wrong pact id"
+ "Invalid Pact ID"
+ (continue-pact 1))
 (commit-tx)
 
 (begin-tx)
-;  ;  (env-exec-config ["DisablePact49"])
 
  ; pact 48 caps
  (interface ops

pact-core-tests/pact-tests/db.repl

@@ -0,0 +1,271 @@
+;  (env-exec-config ["DisablePact44"])
+(env-data { "k": { "keys": ["admin"], "pred": "keys-all" },
+            "k2": { "keys": ["admin"], "pred": "keys-all" } })
+(env-keys ["admin"])
+(begin-tx)
+(define-keyset 'dbtest-admin (read-keyset "k"))
+(module dbtest 'dbtest-admin
+
+  (defschema person
+    name:string
+    age:integer
+    dob:time)
+
+  (deftable persons:{person})
+
+  (deftable persons2:{person})
+
+  (defconst ID_A "A")
+  (defconst ROW_A:object{person}
+    { 'name:"joe", 'age:46, "dob":(parse-time "%F" "1970-01-01") })
+
+  (defun read-persons (k) (read persons k))
+
+  ;  (deftable stuff)
+
+  )
+(define-keyset 'dbtest2-admin (read-keyset "k2"))
+(module dbtest2 'dbtest2-admin
+  (defun read-persons2 (k)
+    (read-persons k)))
+
+(create-table persons)
+;  (create-table stuff)
+
+(commit-tx)
+(use dbtest)
+(begin-tx)
+(use dbtest)
+(insert persons ID_A ROW_A)
+(expect-failure "dupe key should fail" (insert persons ID_A ROW_A))
+(commit-tx)
+(begin-tx)
+(use dbtest)
+(expect "keys works" [ID_A] (keys persons))
+(expect "txids works" [1] (txids persons 0))
+(expect "txlog works"
+        [{"value":ROW_A,"key":ID_A,"table":"USER_dbtest_persons"}]
+        (txlog persons 1))
+
+(expect "keylog works" [{"txid": 1, "value": ROW_A}] (keylog persons ID_A 1))
+
+(env-exec-config ["DisableHistoryInTransactionalMode"])
+(expect-failure
+ "txids disabled"
+ "Operation only permitted in local execution mode"
+ (txids persons 0))
+(expect-failure
+ "txlog disabled"
+ "Operation only permitted in local execution mode"
+ (txlog persons 1))
+(expect-failure
+ "keylog disabled"
+ "Operation only permitted in local execution mode"
+ (keylog persons ID_A 1))
+
+
+;  (insert stuff "k" { "stuff": { "dec": 1.2, "bool": true, "int": -3, "time": (parse-time "%F" "1970-01-01") } })
+;  (expect "object stored as object" "object:*" (typeof (at "stuff" (read stuff "k"))))
+
+(expect "select works" [ROW_A] (select persons (where 'age (= 46))))
+(expect "select works (miss)" [] (select persons (where 'age (= 45))))
+
+(env-keys ["joe"])
+
+(expect "read-persons works w/o admin key" ROW_A (read-persons ID_A))
+(expect "read-persons2 works w/o admin key" ROW_A (dbtest2.read-persons2 ID_A))
+(commit-tx)
+
+;;
+;; test admin table guards
+(env-exec-config []) ;; clear disable history flag except pre-4.2.0
+(begin-tx)
+(use dbtest)
+(expect-failure
+ "write protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (write persons "foo" ROW_A))
+(expect-failure
+ "update protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (update persons "foo" ROW_A))
+(expect-failure
+ "insert protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (insert persons "foo" ROW_A))
+(expect-failure
+ "keys protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (keys persons))
+(expect-failure
+ "txids protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (txids persons 0))
+(expect-failure
+ "txlog protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (txlog persons 2))
+(expect-failure
+ "keylogs protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (keylog persons "" 2))
+(expect-failure
+ "read protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (read persons ID_A))
+(expect-failure
+ "with-read protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (with-read persons ID_A { 'name:= name } name))
+(expect-failure
+ "with-default-read protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (with-default-read persons ID_A { 'name: "stu" } { 'name:= name } name))
+(expect-failure
+ "select protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (select persons (constantly true)))
+(expect-failure
+ "keys protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (keys persons))
+(expect-failure
+ "create-table protected by admin key" "Keyset failure (=): 'dbtest-admin"
+ (create-table persons2))
+
+;; just making sure this doesn't blow up, output is still TBD on better Term output in general
+(describe-table persons)
+
+(commit-tx)
+;; test disabling admin table guards
+(env-exec-config ["AllowReadInLocal"])
+(use dbtest)
+(expect-failure
+ "write protected by admin key in local" "Keyset failure (=): 'dbtest-admin"
+ (write persons "foo" ROW_A))
+(expect-failure
+ "update protected by admin key in local" "Keyset failure (=): 'dbtest-admin"
+ (update persons "foo" ROW_A))
+(expect-failure
+ "insert protected by admin key in local" "Keyset failure (=): 'dbtest-admin"
+ (insert persons "foo" ROW_A))
+(expect
+ "keys allowed in local" [ID_A]
+ (keys persons))
+(expect
+ "txids allowed in local" [1]
+ (txids persons 0))
+(expect
+ "txlog allowed in local" [ID_A]
+ (map (at "key") (txlog persons 1)))
+(expect
+ "keylogs allowed in local" [1]
+ (map (at "txid") (keylog persons ID_A 1)))
+(expect
+ "read allowed in local" "joe"
+ (at "name" (read persons ID_A)))
+(expect
+ "with-read allowed in local" "joe"
+ (with-read persons ID_A { 'name:= name } name))
+(expect
+ "with-default-read allowed in local" "stu"
+ (with-default-read persons "zzz" { 'name: "stu" } { 'name:= name } name))
+(expect
+ "select allowed in local" [46]
+ (map (at "age") (select persons (constantly true))))
+(expect
+ "keys allowed in local" [ID_A]
+ (keys persons))
+(expect-failure
+ "create-table protected by admin key in local" "Keyset failure (=): 'dbtest-admin"
+ (create-table persons2))
+
+;; test nested commits
+
+(begin-tx)
+;  (env-enable-repl-natives true)
+(module nested-tx G
+  (defcap G () true)
+  (defschema s x:integer)
+  (deftable t:{s})
+  (defun test-nested-tx ()
+    (begin-tx)
+    (insert t "a" { 'x: 1 })
+    (commit-tx)
+    (begin-tx)
+    (insert t "b" { 'x: 2 })
+    (rollback-tx)
+    (expect "2nd insert rolled back" ["a"]
+            (keys t))))
+
+(create-table t)
+(commit-tx)
+
+(nested-tx.test-nested-tx)
+
+;; fold-db tests + key sort guarantees
+(env-exec-config [])
+
+(module fdb G
+  (defcap G () true)
+  (defschema fdb-test a:integer b:integer)
+  (deftable fdb-tbl:{fdb-test})
+)
+
+(create-table fdb-tbl)
+;; inserts shuffled to test key sort guarantees:
+;; (insert fdb-tbl 'a {'a:1, 'b:1})
+;; (insert fdb-tbl 'b {'a:2, 'b:2})
+;; (insert fdb-tbl 'c {'a:3, 'b:3})
+;; (insert fdb-tbl 'd {'a:4, 'b:4})
+(insert fdb-tbl 'b {'a:2, 'b:2})
+(insert fdb-tbl 'd {'a:4, 'b:4})
+(insert fdb-tbl 'c {'a:3, 'b:3})
+(insert fdb-tbl 'a {'a:1, 'b:1})
+
+
+(expect
+  "fold-db query filters correctly by key"
+  ["a" "b"]
+  (let*
+    ((qry (lambda (k o)  (< k "c")))
+     (consume (lambda (k o) k))
+    )
+    (fold-db fdb-tbl (qry) (consume))
+    ))
+
+(expect
+  "fold-db query filters correctly by key"
+  ["a" "b"]
+  (let*
+    ((qry (lambda (k o)  (< k "c")))
+     (consume (lambda (k o) k))
+    )
+    (fold-db fdb-tbl (qry) (consume))
+    ))
+
+(expect
+  "fold-db query handles key/obj transform correctly"
+  [["a" 1] ["b" 2]]
+  (let*
+    ((qry (lambda (k o)  (< k "c")))
+     (consume (lambda (k o) [k (at 'a o)]))
+    )
+    (fold-db fdb-tbl (qry) (consume))
+    ))
+
+(expect
+  "fold-db spits out all entries on true qry"
+  [{'entry:'a, 'value:{'a:1, 'b:1}} {'entry:'b, 'value:{'a:2, 'b:2}} {'entry:'c, 'value:{'a:3, 'b:3}} {'entry:'d, 'value:{'a:4, 'b:4}}]
+  (let*
+    ((qry (lambda (k o) true))
+     (consume (lambda (k o) {'entry:k, 'value:o}))
+    )
+    (fold-db fdb-tbl (qry) (consume))
+    ))
+
+(expect
+  "sorted output for keys native for pact 4.2.0"
+  ["a" "b" "c" "d"]
+  (keys fdb-tbl)
+  )
+
+(expect
+  "sorted output based on keys from select for pact 4.2.0"
+  [{"a": 1} {"a": 2} {"a": 3} {"a": 4}]
+  (select fdb-tbl ['a] (constantly true))
+  )
+
+(expect
+  "fold-db query handles key/obj transform correctly: inline lambdas version"
+  [["a" 1] ["b" 2]]
+  (fold-db fdb-tbl (lambda (k o)  (< k "c")) (lambda (k o) [k (at 'a o)]))
+  )