make test almost pass using sqlite backend

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE QuasiQuotes #-}
 -- |
 
 module Pact.Core.Test.PersistenceTests where
@@ -6,17 +7,22 @@ import Control.Monad.IO.Class (liftIO)
 import Hedgehog (Gen, Property, (===), forAll, property)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog
+import Test.Tasty.HUnit
 import qualified Hedgehog.Gen as Gen
 
 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
+import Pact.Core.Gen.Serialise (keySetGen, keySetNameGen, moduleNameGen, moduleDataGen, builtinGen
                                ,defPactIdGen, defPactExecGen, namespaceNameGen, namespaceGen)
 import Pact.Core.Serialise (PactSerialise, serialisePact)
 import Pact.Core.Persistence.SQLite
 import Pact.Core.Persistence (WriteType(Insert), readKeySet, writeKeySet, writeModule, readModule
-                             ,writeDefPacts, readDefPacts, readNamespace, writeNamespace)
+                             ,writeDefPacts, readDefPacts, readNamespace, writeNamespace
+                             , Domain(..), PactDb(_pdbKeys))
+import Pact.Core.Serialise.LegacyPact
+import Data.Foldable (forM_)
+import qualified Data.Text as T
+import Data.String.QQ
 
 testsWithSerial :: (Show b, Show i, Eq b, Eq i) => PactSerialise b i -> Gen b -> Gen i -> [TestTree]
 testsWithSerial serial b i =
@@ -29,8 +35,44 @@ testsWithSerial serial b i =
 tests :: TestTree
 tests = testGroup "Persistence Roundtrip"
   [ testGroup "CBOR encoding/decoding" $ testsWithSerial serialisePact builtinGen (pure ())
+  , testGroup "Regression tests"  [ex1]
   ]
 
+
+ex1 :: TestTree
+ex1 = testCase "DefPact" $
+  assertEqual ""  (Right Nothing) (decodeDefPactExec1 bs)
+  where
+    bs = [s|{"executed":null,"pactId":"44AZc5R-mnuF_ehKF_qXHMzHDnqjVcsdXmRaVbo8g6s","stepHasRollback":false,"step":0,"yield":{"data":{"amount":1,"receiver":"3b60fc72f90fde59d32799c89f550b959b2e9c86f6f8a880af5120c7e62507eb","receiver-guard":{"pred":"keys-all","keys":["3b60fc72f90fde59d32799c89f550b959b2e9c86f6f8a880af5120c7e62507eb"]}},"provenance":{"targetChainId":"0","moduleHash":"ut_J_ZNkoyaPUEJhiwVeWnkSQn9JT9sQCWKdjjVVrWo"}},"continuation":{"args":["9645627f5dad4029f091128e17a030ed15ff6dc554d276824deabbb546488e35","3b60fc72f90fde59d32799c89f550b959b2e9c86f6f8a880af5120c7e62507eb",{"pred":"keys-all","keys":["3b60fc72f90fde59d32799c89f550b959b2e9c86f6f8a880af5120c7e62507eb"]},"0",1],"def":"coin.transfer-crosschain"},"stepCount":2}|]
+
+
+readExistingDb :: FilePath -> IO ()
+readExistingDb fp = withSqlitePactDb serialisePact (T.pack fp) $ \pdb -> do
+  keys <- _pdbKeys pdb DKeySets
+  forM_ keys $ \k -> do
+    print k
+    Just _ <- readKeySet pdb k
+    pure ()
+
+  -- TODO: Implement testing against pact sqlite files
+
+ -- k <- SELECT name FROM sqlite_master WHERE type='table';
+
+
+  -- keys' <- _pdbKeys pdb DNamespaces
+  -- forM_ keys' $ \k -> do
+  --   Just n <- readNamespace pdb k
+  --   print n
+  --   pure ()
+
+  keys'' <- _pdbKeys pdb DDefPacts
+  forM_ keys'' $ \k -> do
+    print k
+    Just _n <- readDefPacts pdb k
+    pure ()
+
+
+
 keysetPersistRoundtrip :: PactSerialise b i -> Gen (KeySet FullyQualifiedName) -> Property
 keysetPersistRoundtrip serial keysetGen =
   property $ do
@@ -50,8 +92,8 @@ moduleDataRoundtrip serial b i = property $ do
     readModule db moduleName
   Just moduleData === writtenModuleData
 
-defPactExecRoundtrip :: (Show b,Show i, Eq b, Eq i) => PactSerialise b i -> Gen b -> Gen i -> Property
-defPactExecRoundtrip serial b i = property $ do
+defPactExecRoundtrip :: PactSerialise b i -> Gen b -> Gen i -> Property
+defPactExecRoundtrip serial _b _i = property $ do
   defPactId <- forAll defPactIdGen
   defPactExec <- forAll (Gen.maybe defPactExecGen)
   writtenDefPactExec <- liftIO $ withSqlitePactDb serial ":memory:" $ \db -> do

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

@@ -1,5 +1,4 @@
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 module Pact.Core.Test.ReplTests where
 
@@ -24,19 +23,18 @@ import Pact.Core.Persistence.MockPersistence
 import Pact.Core.Interpreter
 
 import Pact.Core.Repl.Utils
-import Pact.Core.Persistence (PactDb(..), ModuleData(..), builtinModuleData, infoModuleData)
+import Pact.Core.Persistence (PactDb)
 import Pact.Core.Persistence.SQLite (withSqlitePactDb)
 
 import Pact.Core.Info (SpanInfo)
 import Pact.Core.Compile
-import Pact.Core.IR.Term (Module(..), EvalModule)
 import Pact.Core.Repl.Compile
 import Pact.Core.PactValue
 import Pact.Core.Environment
 import Pact.Core.Builtin
 import Pact.Core.Errors
 import Pact.Core.Serialise
-import Control.Lens
+import Pact.Core.Serialise.CBOR_V1 (encodeModuleData_TESTING, decodeModuleData_TESTING)
 
 tests :: IO TestTree
 tests = do
@@ -46,39 +44,6 @@ tests = do
     , testGroup "sqlite db" (runFileReplTestSqlite <$> files)
     ]
 
-
--- enhanceModuleData :: ModuleData RawBuiltin () -> ModuleData ReplRawBuiltin SpanInfo
--- enhanceModuleData = \case
---   ModuleData _em _defs -> undefined
---   InterfaceData _ifd _defs -> undefined
-
--- stripModuleData :: ModuleData ReplRawBuiltin SpanInfo -> ModuleData RawBuiltin ()
--- stripModuleData = \case
---   ModuleData _em _defs -> undefined
---   InterfaceData _ifd _defs -> undefined
-
--- enhanceEvalModule :: EvalModule RawBuiltin () -> EvalModule ReplRawBuiltin SpanInfo
--- enhanceEvalModule Module
---   { _mName
---   , _mGovernance
---   , _mDefs
---   , _mBlessed
---   , _mImports
---   , _mImplements
---   , _mHash
---   , _mInfo
---   } = Module
---       { _mName
---       , _mGovernance
---       , _mDefs = undefined _mDefs
---       , _mBlessed
---       , _mImports
---       , _mImplements
---       , _mHash
---       , _mInfo = def
---       }
-
-
 replTestDir :: [Char]
 replTestDir = "pact-core-tests" </> "pact-tests"
 
@@ -94,22 +59,11 @@ runFileReplTest file = testCase file $ do
 runFileReplTestSqlite :: TestName -> TestTree
 runFileReplTestSqlite file = testCase file $ do
   ctnt <- B.readFile (replTestDir </> file)
-  withSqlitePactDb (enhance serialisePact) ":memory:" $ \pdb -> do
+  let enc = serialisePact{ _encodeModuleData = encodeModuleData_TESTING
+                         , _decodeModuleData = fmap LegacyDocument . decodeModuleData_TESTING
+                         }
+  withSqlitePactDb enc ":memory:" $ \pdb -> do
     runReplTest pdb file ctnt
-  where
-    enhance :: PactSerialise RawBuiltin () -> PactSerialise ReplRawBuiltin SpanInfo
-    enhance s = s{ _encodeModuleData = \md ->
-                     let encMod = md & builtinModuleData %~ (\(RBuiltinWrap r) -> r)
-                                     & infoModuleData %~ const ()
-                     in _encodeModuleData s encMod
-                 , _decodeModuleData = \bs -> case _decodeModuleData s bs of
-                     Just mdDoc -> Just $ LegacyDocument $ view document mdDoc
-                       & builtinModuleData %~ RBuiltinWrap
-                       & infoModuleData %~ const def
-                     Nothing -> error "unexpected decoding error"
-                 }
-
-
 
 runReplTest :: PactDb ReplRawBuiltin SpanInfo -> FilePath -> ByteString -> Assertion
 runReplTest pdb file src = do

pact-core.cabal

@@ -252,6 +252,7 @@ test-suite core-tests
     , tasty-hedgehog
     , serialise
     , cborg
+    , string-qq
 
   other-modules:
     , Pact.Core.Test.ReplTests

pact-core/Pact/Core/Names.hs

@@ -52,7 +52,6 @@ module Pact.Core.Names
  , fqName
  , fqModule
  , fqHash
--- , userTable
  , DefPactId(..)
  , renderDefPactId
  , parseRenderedModuleName
@@ -346,9 +345,6 @@ instance Eq (FQNameRef name) where
 
 makeLenses ''FullyQualifiedName
 
--- userTable :: TableName -> TableName
--- userTable (TableName tn) = TableName ("USER_" <> tn)
-
 -- | The identifier that indexes defpacts in the db,
 --   generally computed from the continuation, or
 --   in the case of nested defpacts, the hash of the

pact-core/Pact/Core/Persistence.hs

@@ -34,7 +34,6 @@ module Pact.Core.Persistence
  , dbOpDisallowed
  , toUserTable
  , FQKS
- , builtinModuleData , infoModuleData
  ) where
 
 import Control.Lens
@@ -43,7 +42,6 @@ import Control.Applicative((<|>))
 import Data.Default
 import Data.IORef (IORef)
 import Data.Map.Strict(Map)
---import Data.Maybe(isJust)
 import Data.Text(Text)
 import Data.Word(Word64)
 
@@ -67,60 +65,6 @@ data ModuleData b i
   | InterfaceData (EvalInterface b i) (Map FullyQualifiedName (EvalDef b i))
   deriving (Show, Eq, Functor)
 
-builtinEvalModule :: Traversal (EvalModule b i) (EvalModule b' i) b b'
-builtinEvalModule = undefined
-
-infoEvalModule :: Traversal (EvalModule b i) (EvalModule b i') i i'
-infoEvalModule = undefined
-
-builtinEvalInterface :: Traversal (EvalInterface b i) (EvalInterface b' i) b b'
-builtinEvalInterface = undefined
-
-infoEvalInterface :: Traversal (EvalInterface b i) (EvalInterface b i') i i'
-infoEvalInterface = undefined
-
-builtinEvalDef :: Traversal (EvalDef b i) (EvalDef b' i) b b'
-builtinEvalDef = undefined
-
-infoDefun :: Traversal (Defun name ty builtin i) (Defun name ty builtin i') i i'
-infoDefun f (Defun n a r t i) = Defun n a r <$> termInfo' f t <*> f i
-
-infoConst :: Traversal (DefConst name ty builtin i) (DefConst name ty builtin i') i i'
-infoConst f (DefConst n r t i) = DefConst n r <$> termInfo' f t <*> f i
-
-infoDefCap :: Traversal (DefCap name ty builtin i) (DefCap name ty builtin i') i i'
-infoDefCap f (DefCap n ar arg rt t m i) = DefCap n ar arg rt <$> termInfo' f t <*> pure m <*> f i
-
-infoDefSchema :: Traversal (DefSchema ty i) (DefSchema ty i') i i'
-infoDefSchema f (DefSchema n schema i) = DefSchema n schema <$> f i
-
-infoDefTable :: Traversal (DefTable ty i) (DefTable ty i') i i'
-infoDefTable f (DefTable n schema i) = DefTable n schema <$> f i
-
-infoStep :: Traversal (Step name ty builtin i) (Step name ty builtin i') i i'
-infoStep f (Step t m) = Step <$> termInfo' f t <*> (traverse . traverse) (termInfo' f) m
-infoStep f (StepWithRollback t r m) = StepWithRollback <$> termInfo' f t <*> termInfo' f r <*> (traverse . traverse) (termInfo' f) m
-
-infoDefPact :: Traversal (DefPact name ty builtin i) (DefPact name ty builtin i') i i'
-infoDefPact f (DefPact n ad rt s i) = DefPact n ad rt <$> traverse (infoStep f) s <*> f i
-
-infoEvalDef :: Traversal (EvalDef b i) (EvalDef b i') i i'
-infoEvalDef f (Dfun defun) = Dfun <$> infoDefun f defun
-infoEvalDef f (DConst d) = DConst <$> infoConst f d
-infoEvalDef f (DCap cap) = DCap <$> infoDefCap f cap
-infoEvalDef f (DSchema schema) = DSchema <$> infoDefSchema f schema
-infoEvalDef f (DTable table) = DTable <$> infoDefTable f table
-infoEvalDef f (DPact pact) = DPact <$> infoDefPact f pact
-
-builtinModuleData :: Traversal (ModuleData b i) (ModuleData b' i) b b'
-builtinModuleData f (ModuleData m dep) = ModuleData <$> builtinEvalModule f m <*> traverse (builtinEvalDef f) dep
-builtinModuleData f (InterfaceData m dep) = InterfaceData <$> builtinEvalInterface f m <*> traverse (builtinEvalDef f) dep
-
-infoModuleData :: Traversal (ModuleData b i) (ModuleData b i') i i'
-infoModuleData f (ModuleData m dep) = ModuleData <$> infoEvalModule f m <*> traverse (infoEvalDef f) dep
-infoModuleData f (InterfaceData m dep) = InterfaceData <$> infoEvalInterface f m <*> traverse (infoEvalDef f) dep
-
-
 mdModuleName :: Lens' (ModuleData b i) ModuleName
 mdModuleName f = \case
   ModuleData ev deps ->