Tables as values in pact

gasmodel/Pact/Core/GasModel/Utils.hs

@@ -24,7 +24,6 @@ import Pact.Core.Literal
 import Pact.Core.Type
 import Pact.Core.Capabilities
 import Pact.Core.IR.Desugar
-import Pact.Core.IR.Eval.Runtime
 import Pact.Core.IR.Eval.CEK.CoreBuiltin
 import Pact.Core.PactValue
 import Pact.Core.IR.Term

pact-tests/Pact/Core/Test/JSONRoundtripTests.hs

@@ -62,7 +62,10 @@ tests = testGroup "JSON Roundtrips" $ stableEncodings ++ jsonRoundtrips
     , StableEncodingCase defPactExecGen
     , StableEncodingCase namespaceGen
     , StableEncodingCase pactEventGen
+    , StableEncodingCase tableNameGen
+    , StableEncodingCase tableValueGen
     , StableEncodingCase spanInfoGen
+    , StableEncodingCase typeGen
     ]
   jsonRoundtrips = fmap testJSONRoundtrip $
     [ EncodingCase signerGen

pact-tests/Pact/Core/Test/LexerParserTests.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Pact.Core.Test.LexerParserTests where
 
 import Test.Tasty
@@ -12,10 +14,8 @@ import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 import qualified Data.Text as T
 
-import Pact.Core.Gen
-  (moduleHashGen, parsedTyNameGen, parsedNameGen
-  , moduleNameGen, identGen
-  , decimalGen)
+import Pact.Core.Gen hiding
+ (typeGen, argGen, defunGen, importGen, defGen, ifDefGen, stepGen)
 import qualified Pact.Core.Syntax.Lexer as Lisp
 import qualified Pact.Core.Syntax.LexUtils as Lisp
 import Pact.Core.Syntax.ParseTree as Lisp
@@ -25,6 +25,8 @@ import Pact.Core.Literal
 import Pact.Core.Pretty
 import Pact.Core.Hash
 import Pact.Core.Info
+import Data.Typeable
+import Pact.Core.Names
 
 showPretty :: Pretty a => a -> T.Text
 showPretty = T.pack . show . pretty
@@ -382,6 +384,38 @@ parserRoundtrip = property $ do
   res <- evalEither $ Lisp.parseProgram =<< Lisp.lexer (renderCompactText ptok)
   [ptok] === (void <$> res)
 
+data RenderTest =
+  forall a. (Eq a, Show a, Typeable a) => MkRenderTest
+  { _renderGen :: Gen a
+  , _renderText :: a -> Text
+  , _renderParse :: Text -> Maybe a
+  , _renderProxy :: Proxy a
+  }
+
+renderTest :: (Eq a, Typeable a, Show a) => Gen a -> (a -> Text) -> (Text -> Maybe a) -> RenderTest
+renderTest gen render parse = MkRenderTest gen render parse Proxy
+
+parseExprMaybe :: Text -> Maybe (Lisp.Expr ())
+parseExprMaybe = fmap void . either (const Nothing) Just . (Lisp.lexer >=> Lisp.parseExpr)
+
+runRenderTest :: RenderTest -> TestTree
+runRenderTest (MkRenderTest gen render parse prx) =
+  testProperty ("Render/parse test for: " <> show (typeRep prx)) $ withTests (1000 :: TestLimit) $
+    property $ do
+    v <- forAll gen
+    parse (render v) === Just v
+
+renderTests :: [RenderTest]
+renderTests =
+    -- Render test litmus using expr
+  [ renderTest exprGen renderCompactText parseExprMaybe
+  , renderTest fullyQualifiedNameGen renderFullyQualName parseFullyQualifiedName
+  , renderTest moduleNameGen renderModuleName parseModuleName
+  , renderTest tableNameGen jsonSafeRenderTableName parseJsonSafeTableName
+  , renderTest parsedTyNameGen renderParsedTyName parseParsedTyName
+  , renderTest hashedModuleNameGen renderHashedModuleName parseHashedModuleName
+  ]
+
 -- | Here we will test that slicing from generated source
 --   will produce accurate source locations
 --
@@ -400,7 +434,7 @@ sliceRoundtrip = property $ do
 tests :: TestTree
 tests = testGroup "Lexer and Parser Tests"
   [ testProperty "lexer roundtrip" lexerRoundtrip
-  , testProperty "parser roundtrips for exprs" $ withTests (1000 :: TestLimit) exprParserRoundtrip
   , testProperty "parser roundtrips for all toplevels" $ withTests (1000 :: TestLimit) parserRoundtrip
   , testProperty "source slices correspond with their source code locations" $ withTests (1000 :: TestLimit) sliceRoundtrip
+  , testGroup "Render/parse tests" $ runRenderTest <$> renderTests
   ]

pact-tests/legacy-serial-tests/coin-v5/coin-v5.repl

@@ -544,7 +544,7 @@
 ; using Pact40 error messages
 (expect-failure
   "create side of cross-chain transfer fails yield on wrong chain"
-  "yield provenance"
+  "Yield provenance does not match"
   (continue-pact 1 false (hash "burn-create")
     { "create-account": 'doug
     , "create-account-guard": (read-keyset 'doug)
@@ -562,7 +562,7 @@
 ; double spends are disallowed by construction
 (expect-failure
   "cross-chain transfer pact prevents double spends"
-  "pact completed"
+  "Requested defpact already completed"
   (continue-pact 1 false (hash "burn-create")))
 
 ; account guard rotation
@@ -768,7 +768,7 @@
 
 (expect-failure
  "account creation fails when no keyset corresponds with keyset ref"
- "no such keyset defined"
+ "Cannot find keyset in database: 'brandon"
  (create-allocation-account "brandon" (time "2020-10-31T00:00:00Z") "brandon" 200000.0))
 
 ; successful keyset refs require defined keyset

pact-tests/legacy-serial-tests/marmalade-v2/marmalade.repl

@@ -274,7 +274,7 @@
     })
 
   (expect-failure "offer fails when called directly"
-    "pact-id: not in pact execution"
+    "Attempted to fetch defpact data, but currently not within defpact execution"
     (offer (read-string "token-id") (read-string "account") 1.0)
   )
 

pact-tests/pact-tests/base64.repl

@@ -22,22 +22,22 @@
 
 (expect-failure
   "base64 decoding fails on non base64-encoded input"
-  "Could not decode string"
+  "Decoding error: invalid b64 encoding"
   (base64-decode "aGVsbG8gd29ybGQh%"))
 
 (expect-failure
   "base64 decoding fails on garbage input 1"
-  "Could not decode string"
+  "Decoding error: invalid b64 encoding"
   (base64-decode "aaa"))
 
 (expect-failure
   "base64 decoding fails on garbage input 2"
-  "Could not decode string"
+  "Decoding error: invalid b64 encoding"
   (base64-decode "asdflk"))
 
 (expect-failure
   "base64 decoding fails on garbage input 3"
-  "Could not decode string"
+  "Decoding error: invalid b64 encoding"
   (base64-decode "!@#$%&"))
 
 ; Todo: unicode escape codes?
@@ -53,5 +53,5 @@
 
 (expect-failure
   "base64 decoding fails on non-canonical encodings"
-  "Could not base64-decode string"
+  "Decoding error: invalid b64 encoding"
   (base64-decode "ZE=="))

pact-tests/pact-tests/caps.repl

@@ -752,12 +752,12 @@
 
 (expect-failure
  "emit-event: must be in module"
- "Unable to resolve current calling module"
+ "Emitted event does not match module: events"
  (emit-event (EV)))
 
 (expect-failure
  "emit-event: non-event"
- "must be managed or event defcap"
+ "Invalid event capability events.NON.{Pl17Zu2iMddv942W_ChGFDyPWN4zFVjtVvI8HP4_0AY}"
  (emit-non-event))
 
 (expect
@@ -993,7 +993,7 @@
    )
 
    (defun emit-a(a:integer) (emit-event (A_EVENT a a))))
-   
+
 
 (use B)
 (call-a)

pact-tests/pact-tests/coin-v1.repl

@@ -526,7 +526,7 @@
 ;  (env-exec-config ['DisablePact40, 'DisableInlineMemCheck, 'DisablePact43, "DisablePact44", "DisablePact45"])
 (expect-failure
   "create side of cross-chain transfer fails yield on wrong chain"
-  "does not match (chain"
+  "Yield provenance does not match"
   (continue-pact 1 false (hash "burn-create")
     { "create-account": 'doug
     , "create-account-guard": (read-keyset 'doug)
@@ -548,7 +548,7 @@
 ; double spends are disallowed by construction
 (expect-failure
   "cross-chain transfer pact prevents double spends"
-  "pact completed"
+  "Requested defpact already completed"
   (continue-pact 1 false (hash "burn-create")))
 
 ; account guard rotation
@@ -723,7 +723,7 @@
 
 (expect-failure
  "account creation fails when no keyset corresponds with keyset ref"
- "no such keyset defined"
+ "Cannot find keyset in database: 'brandon"
  (create-allocation-account "brandon" (time "2020-10-31T00:00:00Z") "brandon" 200000.0))
 
 ; successful keyset refs require defined keyset

pact-tests/pact-tests/coin-v5.repl

@@ -555,7 +555,7 @@
 ; using Pact40 error messages
 (expect-failure
   "create side of cross-chain transfer fails yield on wrong chain"
-  "yield provenance"
+  "Yield provenance does not match"
   (continue-pact 1 false (hash "burn-create")
     { "create-account": 'doug
     , "create-account-guard": (read-keyset 'doug)
@@ -573,7 +573,7 @@
 ; double spends are disallowed by construction
 (expect-failure
   "cross-chain transfer pact prevents double spends"
-  "pact completed"
+  "Requested defpact already completed:  defpact id:UT9N17TRzn2FmWlZdT_S7y-AC1A_yOugNbfRSz4VFPE"
   (continue-pact 1 false (hash "burn-create")))
 
 ; account guard rotation
@@ -779,7 +779,7 @@
 
 (expect-failure
  "account creation fails when no keyset corresponds with keyset ref"
- "no such keyset defined"
+ "Cannot find keyset in database: 'brandon"
  (create-allocation-account "brandon" (time "2020-10-31T00:00:00Z") "brandon" 200000.0))
 
 ; successful keyset refs require defined keyset

pact-tests/pact-tests/db.repl

@@ -64,35 +64,46 @@
 (env-exec-config []) ;; clear disable history flag except pre-4.2.0
 (begin-tx)
 (use dbtest)
+(expect-failure "module admin protected by admin-key" "Keyset failure (keys-all): [admin...]" (acquire-module-admin dbtest))
 (expect-failure
- "write protected by admin key" "Keyset failure"
+ "write protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (write persons "foo" ROW_A))
 (expect-failure
- "update protected by admin key" "Keyset failure"
+ "update protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (update persons "foo" ROW_A))
 (expect-failure
- "insert protected by admin key" "Keyset failure"
+ "insert protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (insert persons "foo" ROW_A))
 (expect-failure
- "keys protected by admin key" "Keyset failure"
+ "keys protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (keys persons))
 (expect-failure
- "read protected by admin key" "Keyset failure"
+ "read protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (read persons ID_A))
 (expect-failure
- "with-read protected by admin key" "Keyset failure"
+ "with-read protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (with-read persons ID_A { 'name:= name } name))
 (expect-failure
- "with-default-read protected by admin key" "Keyset failure"
+ "with-default-read protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (with-default-read persons ID_A { 'name: "stu" } { 'name:= name } name))
 (expect-failure
- "select protected by admin key" "Keyset failure"
+ "select protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (select persons (constantly true)))
 (expect-failure
- "keys protected by admin key" "Keyset failure"
+ "keys protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (keys persons))
 (expect-failure
- "create-table protected by admin key" "Keyset failure"
+ "create-table protected by admin key"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (create-table persons2))
 
 ;; just making sure this doesn't blow up, output is still TBD on better Term output in general
@@ -103,13 +114,16 @@
 (env-exec-config ["AllowReadInLocal"])
 (use dbtest)
 (expect-failure
- "write protected by admin key in local" "Keyset failure"
+ "write protected by admin key in local"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (write persons "foo" ROW_A))
 (expect-failure
- "update protected by admin key in local" "Keyset failure"
+ "update protected by admin key in local"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (update persons "foo" ROW_A))
 (expect-failure
- "insert protected by admin key in local" "Keyset failure"
+ "insert protected by admin key in local"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (insert persons "foo" ROW_A))
 (expect
  "keys allowed in local" [ID_A]
@@ -130,7 +144,8 @@
  "keys allowed in local" [ID_A]
  (keys persons))
 (expect-failure
- "create-table protected by admin key in local" "Keyset failure"
+ "create-table protected by admin key in local"
+ "Module admin necessary for operation but has not been acquired:dbtest"
  (create-table persons2))
 
 ;; test nested commits
@@ -287,3 +302,40 @@
 (expect "selecting with fields on empty fields" [{"a": 2} {"a": 3}] (select tbl ["a"] (constantly true)))
 (expect "selecting with fields with no fields results in empty objects" [{} {}] (select tbl [] (constantly true)))
 (commit-tx)
+
+; DB regression
+(begin-tx)
+(module table-abstraction g (defcap g () true)
+  (defschema sc a:integer b:integer)
+  (defschema sc2 a:integer b:integer c:string)
+  (defschema sc3 a:integer b:integer)
+  (deftable tbl:{sc})
+  (deftable tbl2:{sc2})
+  (deftable tbl3:{sc3})
+  (deftable tbl4:{sc})
+
+  (defun write-to-table:unit (tv:table{sc} k:string v:object{sc})
+    (write tv k v)
+    ()
+  )
+
+  (defun read-from-tables:[object{sc}] (tvs:[table{sc}] k:string)
+    (map (lambda (tv) (read tv k)) tvs)
+  )
+
+)
+
+(create-table tbl)
+(create-table tbl2)
+(create-table tbl3)
+(create-table tbl4)
+
+(expect "can write to table tbl" () (write-to-table tbl "jose" {"a": 1, "b": 2}))
+(expect-failure "Cannot write to tbl2: different schema" "Runtime typecheck failure" (write-to-table tbl2 "jose" {"a": 2, "b": 2}))
+(expect "can write to table tbl4: same schema" () (write-to-table tbl4 "jose" {"a": 3, "b": 2}))
+(expect "can write to table tbl3: different schema, same structure" () (write-to-table tbl3 "jose" {"a": 4, "b": 2}))
+
+(expect "can read from tables with the same schema" [{"a": 1,"b": 2} {"a": 3,"b": 2} {"a": 4,"b": 2}]  (read-from-tables [tbl, tbl4, tbl3] "jose"))
+(expect-failure "Cannot read from tables with different schema" "Runtime typecheck failure" (read-from-tables [tbl, tbl2] "jose"))  
+
+(commit-tx)

pact-tests/pact-tests/defpact.repl

@@ -19,7 +19,7 @@
 (use defcap-module)
 
 (expect "should return 'step-0'" "step-0" (defpact-single-step))
-(expect-failure "should not executing step again" "not-step-0" (defpact-single-step))
+(expect-failure "should not executing step again" "defpact execution context already in the environment" (defpact-single-step))
 (commit-tx)
 
 

pact-tests/pact-tests/gov.repl

@@ -79,5 +79,5 @@
 (expect-failure
  "gov not granted after install"
  "autonomous-ns-gov"
- (write user.ns-gov.t "a" { 's: "x" }))
+ (acquire-module-admin user.ns-gov))