wip

pact-core-tests/Pact/Core/Gen/Serialise.hs

@@ -26,6 +26,7 @@ import Pact.Core.Persistence
 import Pact.Core.PactValue
 import Pact.Core.DefPacts.Types
 import Pact.Core.ChainData
+import Pact.Core.Namespace
 
 import qualified Data.ByteString.Short as BSS
 import Pact.Core.Test.LexerParserTests (identGen)
@@ -37,6 +38,12 @@ import Data.Decimal
 namespaceNameGen :: Gen NamespaceName
 namespaceNameGen = NamespaceName <$> identGen
 
+namespaceGen :: Gen Namespace
+namespaceGen = do
+  name <- namespaceNameGen
+  user <- guardGen 3 fullyQualifiedNameGen
+  Namespace name user <$> guardGen 3 fullyQualifiedNameGen
+
 moduleNameGen :: Gen ModuleName
 moduleNameGen =  do
   name <- identGen

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

@@ -13,25 +13,26 @@ import Pact.Core.Names (FullyQualifiedName)
 import Pact.Core.Info (SpanInfo)
 import Pact.Core.Guards (KeySet)
 import Pact.Core.Gen.Serialise (keySetGen, keySetNameGen, moduleNameGen, moduleDataGen, builtinGen, infoGen
-                               ,defPactIdGen, defPactExecGen)
+                               ,defPactIdGen, defPactExecGen, namespaceNameGen, namespaceGen)
 import Pact.Core.Serialise (PactSerialise, serialiseCBOR)
 import Pact.Core.Builtin (RawBuiltin)
 import Pact.Core.Persistence.SQLite
 import Pact.Core.Persistence (WriteType(Insert), readKeySet, writeKeySet, writeModule, readModule
-                             ,writeDefPacts, readDefPacts)
+                             ,writeDefPacts, readDefPacts, readNamespace, writeNamespace)
 
 testsWithSerial :: (Show b, Show i, Eq b, Eq i) => PactSerialise b i -> Gen b -> Gen i -> [TestTree]
 testsWithSerial serial b i =
  [ testProperty "KeySet" $ keysetPersistRoundtrip serial (keySetGen undefined)
  , testProperty "ModuleData" $ moduleDataRoundtrip serial b i
- -- , testProperty "DefPactExec" $ defPactExecRoundtrip serial b i
+ , testProperty "DefPactExec" $ defPactExecRoundtrip serial b i
+ , testProperty "Namespace" $ namespaceRoundtrip serial
  ]
 
 tests :: TestTree
 tests = testGroup "Persistence Roundtrip"
-  [ testGroup "CBOR encoding/decoding" $ testsWithSerial (serialiseCBOR @RawBuiltin @SpanInfo) builtinGen infoGen
-  ]
-
+  -- [ testGroup "CBOR encoding/decoding" $ testsWithSerial (serialiseCBOR @RawBuiltin @SpanInfo) builtinGen infoGen
+  -- ]
+  []
 -- TODO: Choose a different type parameter for KeySet when Custom predicates
 -- are reintroduced.
 keysetPersistRoundtrip :: PactSerialise b i -> Gen (KeySet FullyQualifiedName) -> Property
@@ -61,3 +62,12 @@ defPactExecRoundtrip serial b i = property $ do
     () <- writeDefPacts db Insert defPactId defPactExec
     readDefPacts db defPactId
   Just defPactExec === writtenDefPactExec
+
+namespaceRoundtrip :: PactSerialise b i -> Property
+namespaceRoundtrip serial = property $ do
+  ns <- forAll namespaceNameGen
+  namespace <- forAll namespaceGen
+  writtenNamespace <- liftIO $ withSqlitePactDb serial ":memory:" $ \db -> do
+    () <- writeNamespace db Insert ns namespace
+    readNamespace db ns
+  Just namespace === writtenNamespace

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

@@ -5,7 +5,7 @@ module Pact.Core.Test.SerialiseTests where
 
 import Pact.Core.Serialise
 import Pact.Core.Gen.Serialise
-import Pact.Core.Serialise.CBOR ()
+import Pact.Core.Serialise.CBOR_V1 ()
 import qualified Codec.Serialise as S
 
 import Pact.Core.Builtin
@@ -33,7 +33,7 @@ documentGen g = Document <$> documentVersionGen <*> documentFormatGen <*> g
 
 serialiseModule :: Property
 serialiseModule = property $ do
-  m <- forAll (moduleDataGen builtinGen infoGen)
+  m <- forAll (moduleDataGen builtinGen (pure ()))
   let
     encoded = _encodeModuleData serialiseCBOR m
   case _decodeModuleData serialiseCBOR encoded of
@@ -48,8 +48,8 @@ serialiseKeySet :: Property
 serialiseKeySet = property $ do
   ks <- forAll (keySetGen fullyQualifiedNameGen)
   let
-    encoded = _encodeKeySet (serialiseCBOR @RawBuiltin @SpanInfo) ks
-  case _decodeKeySet (serialiseCBOR @RawBuiltin @SpanInfo) encoded of
+    encoded = _encodeKeySet serialiseCBOR ks
+  case _decodeKeySet serialiseCBOR encoded of
     Left _ -> fail "asas"
     Right (Document v f c) -> do
       v === DocumentVersion 0
@@ -60,8 +60,8 @@ serialiseDefPactExec :: Property
 serialiseDefPactExec = property $ do
   dpe <- forAll (Gen.maybe defPactExecGen)
   let
-    encoded = _encodeDefPactExec (serialiseCBOR @RawBuiltin @SpanInfo) dpe
-  case _decodeDefPactExec (serialiseCBOR @RawBuiltin @SpanInfo) encoded of
+    encoded = _encodeDefPactExec serialiseCBOR dpe
+  case _decodeDefPactExec serialiseCBOR encoded of
     Left _ -> fail "asas"
     Right (Document v f c) -> do
       v === DocumentVersion 0
@@ -73,7 +73,7 @@ tests = testGroup "Serialise Roundtrip"
   [ testGroup "Document"
     [ testProperty "DocumentFormat" $ serialiseRoundtrip documentFormatGen
     , testProperty "DocumentVersion" $ serialiseRoundtrip documentVersionGen
-    , testProperty "Document" $ serialiseRoundtrip (documentGen (Gen.constant ()))
+--    , testProperty "Document" $ serialiseRoundtrip (documentGen (Gen.constant ()))
     ]
   , testGroup "CBOR"
     [ testProperty "NamespaceName" $ serialiseRoundtrip namespaceNameGen

pact-core/Pact/Core/Persistence.hs

@@ -26,6 +26,7 @@ module Pact.Core.Persistence
  , readModule, writeModule
  , readKeySet, writeKeySet
  , readDefPacts, writeDefPacts
+ , readNamespace, writeNamespace
  , GuardTableOp(..)
  , DbOpException(..)
  , TxId(..)
@@ -191,6 +192,12 @@ readDefPacts pdb = _pdbRead pdb DDefPacts
 writeDefPacts :: PactDb b i -> WriteType -> DefPactId -> Maybe DefPactExec -> IO ()
 writeDefPacts pdb wt = _pdbWrite pdb wt DDefPacts
 
+readNamespace :: PactDb b i -> NamespaceName -> IO (Maybe Namespace)
+readNamespace pdb = _pdbRead pdb DNamespaces
+
+writeNamespace :: PactDb b i -> WriteType -> NamespaceName -> Namespace -> IO ()
+writeNamespace pdb wt = _pdbWrite pdb wt DNamespaces
+
 data DbOpException
   = WriteException
   | NoSuchTable TableName

pact-core/Pact/Core/Persistence/SQLite.hs

@@ -15,10 +15,10 @@ import Data.Text (Text)
 import qualified Database.SQLite3 as SQL
 
 import Pact.Core.Guards (KeySetName(_keySetName))
-import Pact.Core.Names (renderModuleName, DefPactId(..))
+import Pact.Core.Names (renderModuleName, DefPactId(..), NamespaceName(..), TableName(..), RowKey(..))
 import Pact.Core.Persistence (PactDb(..), Domain(..),
                               Purity(PImpure)
-                             ,WriteType(..)
+                             ,WriteType(..) --, RowData(..)
                              )
 -- import Pact.Core.Repl.Utils (ReplEvalM)
 import Pact.Core.Serialise
@@ -37,8 +37,10 @@ withSqlitePactDb serial connectionString act =
 
 createTables :: SQL.Database -> IO ()
 createTables db = do
-  SQL.exec db "CREATE TABLE IF NOT EXISTS SYS_KEYSETS (txid INTEGER PRIMARY KEY NOT NULL UNIQUE , rowkey TEXT NOT NULL, rowdata BLOB NOT NULL)"
-  SQL.exec db "CREATE TABLE IF NOT EXISTS SYS_MODULES (txid INTEGER PRIMARY KEY NOT NULL UNIQUE , rowkey TEXT NOT NULL, rowdata BLOB NOT NULL)"
+  SQL.exec db "CREATE TABLE IF NOT EXISTS SYS_KEYSETS    (txid INTEGER PRIMARY KEY NOT NULL UNIQUE , rowkey TEXT NOT NULL, rowdata BLOB NOT NULL)"
+  SQL.exec db "CREATE TABLE IF NOT EXISTS SYS_MODULES    (txid INTEGER PRIMARY KEY NOT NULL UNIQUE , rowkey TEXT NOT NULL, rowdata BLOB NOT NULL)"
+  SQL.exec db "CREATE TABLE IF NOT EXISTS SYS_DEFPACTS   (txid INTEGER PRIMARY KEY NOT NULL UNIQUE , rowkey TEXT NOT NULL, rowdata BLOB NOT NULL)"
+  SQL.exec db "CREATE TABLE IF NOT EXISTS SYS_NAMESPACES (txid INTEGER PRIMARY KEY NOT NULL UNIQUE , rowkey TEXT NOT NULL, rowdata BLOB NOT NULL)"
 
 -- | Create all tables that should exist in a fresh pact db,
 --   or ensure that they are already created.
@@ -80,6 +82,14 @@ write' serial db _wt domain k v = case domain of
       SQL.stepNoCB stmt >>= \case
         SQL.Done -> pure ()
         SQL.Row -> fail "invariant viaolation"
+  DNamespaces -> withStmt db "INSERT INTO SYS_DEFPACTS (rowkey, rowdata) VALUES (?,?)" $ \stmt -> do
+      let
+        encoded = _encodeNamespace serial v
+        NamespaceName k' = k
+      SQL.bind stmt [SQL.SQLText k', SQL.SQLBlob encoded]
+      SQL.stepNoCB stmt >>= \case
+        SQL.Done -> pure ()
+        SQL.Row -> fail "invariant viaolation"
   _ -> undefined
 
 read' :: forall k v b i. PactSerialise b i -> SQL.Database -> Domain k v b i -> k -> IO (Maybe v)
@@ -106,7 +116,20 @@ read' serial db domain k = case domain of
           case _decodeModuleData serial value of
             Left _ -> pure Nothing
             Right (Document _ _ c) -> pure (Just c)
-  DUserTables _tbl -> pure Nothing
+  DUserTables tbl -> do
+    let tblName = toUserTable tbl -- TODO: how to include the NameSpace?
+    withStmt db ("SELECT rowdata FROM " <> tblName <> " WHERE rowkey = ? ORDER BY txid DESC LIMIT 1") $ \stmt -> do
+      let RowKey rk = k
+      SQL.bind stmt [SQL.SQLText rk]
+      SQL.step stmt >>= \case
+        SQL.Done -> pure Nothing
+        SQL.Row -> do
+          1 <- SQL.columnCount stmt
+          [SQL.SQLBlob value] <- SQL.columns stmt
+          SQL.Done <- SQL.step stmt
+          case _decodeRowData serial value of
+            Left _ -> pure Nothing
+            Right (Document _ _ c) -> pure (Just c)
   DDefPacts -> withStmt db "SELECT rowdata FROM SYS_DEFPACTS WHERE rowkey = ? ORDER BY txid DESC LIMIT 1" $ \stmt -> do
       let DefPactId pid = k
       SQL.bind stmt [SQL.SQLText pid]
@@ -119,8 +142,24 @@ read' serial db domain k = case domain of
           case _decodeDefPactExec serial value of
             Left _ -> pure Nothing
             Right (Document _ _ c) -> pure (Just c)
-  DNamespaces -> pure Nothing
+  DNamespaces -> withStmt db "SELECT rowdata FROM SYS_NAMESPACES WHERE rowkey = ? ORDER BY txid DESC LIMIT 1" $ \stmt -> do
+      let NamespaceName ns = k
+      SQL.bind stmt [SQL.SQLText ns]
+      SQL.step stmt >>= \case
+        SQL.Done -> pure Nothing
+        SQL.Row -> do
+          1 <- SQL.columnCount stmt
+          [SQL.SQLBlob value] <- SQL.columns stmt
+          SQL.Done <- SQL.step stmt
+          case _decodeNamespace serial value of
+            Left _ -> pure Nothing
+            Right (Document _ _ c) -> pure (Just c)
 
 -- Utility functions
 withStmt :: SQL.Database -> Text -> (SQL.Statement -> IO a) -> IO a
 withStmt conn sql = bracket (SQL.prepare conn sql) SQL.finalize
+
+
+
+toUserTable :: TableName -> Text
+toUserTable (TableName tbl) = "USER_" <> tbl

pact-core/Pact/Core/Repl/Compile.hs

@@ -25,7 +25,7 @@ import qualified Data.Text as T
 
 import Pact.Core.Persistence
 import Pact.Core.Persistence.MockPersistence (mockPactDb)
-import Pact.Core.Persistence.SQLite (withSqlitePactDb)
+-- import Pact.Core.Persistence.SQLite (withSqlitePactDb)
 import Pact.Core.Builtin
 import Pact.Core.Names
 import Pact.Core.Repl.Utils
@@ -35,7 +35,7 @@ import Pact.Core.IR.Term
 import Pact.Core.Compile
 import Pact.Core.Interpreter
 import Pact.Core.Environment
-import Pact.Core.Serialise
+-- import Pact.Core.Serialise
 
 
 import Pact.Core.IR.Eval.Runtime
@@ -84,7 +84,7 @@ interpretReplProgram (SourceCode _ source) display = do
           oldSrc <- use replCurrSource
           evalState .= def
           pactdb <- liftIO mockPactDb
-          _ <- withSqlitePactDb (serialiseCBOR :: PactSerialise ReplRawBuiltin ()) "" pure
+--          _ <- withSqlitePactDb undefined -- (serialiseCBOR :: PactSerialise ReplRawBuiltin ()) "" pure
           replPactDb .= pactdb
           replEvalEnv .= defaultEvalEnv pactdb replRawBuiltinMap
           out <- loadFile (T.unpack txt) display