feature: support for reflecting db contents into another db

docs/en/pact-functions.md

@@ -461,7 +461,7 @@ Return ID if called during current pact execution, failing if not.
 Obtain current pact build version.
 ```lisp
 pact> (pact-version)
-"4.11"
+"4.12"
 ```
 
 Top level only: this function will fail if used in module code.

pact.cabal

@@ -128,6 +128,7 @@ library
     Pact.Persist.MockPersist
     Pact.Persist.Pure
     Pact.Persist.SQLite
+    Pact.Persist.Taped
     Pact.PersistPactDb
     Pact.PersistPactDb.Regression
     Pact.Repl

src/Pact/MockDb.hs

@@ -25,8 +25,8 @@ newtype MockTxIds =
 instance Default MockTxIds where def = MockTxIds (\_t _i -> rc [])
 
 newtype MockGetUserTableInfo =
-  MockGetUserTableInfo (TableName -> Method () ModuleName)
-instance Default MockGetUserTableInfo where def = MockGetUserTableInfo (\_t -> rc "")
+  MockGetUserTableInfo (TableName -> Method () (Maybe ModuleName))
+instance Default MockGetUserTableInfo where def = MockGetUserTableInfo (\_t -> rc (Just ""))
 
 newtype MockCommitTx =
   MockCommitTx (Method () [TxLogJson])

src/Pact/Persist.hs

@@ -4,6 +4,10 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Pact.Persist
   (Persist,
@@ -25,28 +29,56 @@ import Data.String
 import Data.Hashable
 import Data.Text (Text)
 import Data.Typeable (Typeable)
+import GHC.Generics
 
 import Pact.Types.Pretty
 import Pact.Types.Runtime
 
 type Persist s a = s -> IO (s,a)
 
 newtype DataKey = DataKey Text
-  deriving (Eq,Ord,IsString,AsString,Hashable,Pretty)
+  deriving (Eq,Generic,Ord)
+  deriving newtype (FromJSONKey, ToJSONKey, IsString, AsString, Hashable, Pretty)
 instance Show DataKey where show (DataKey k) = show k
 newtype TxKey = TxKey Integer
-  deriving (Eq,Ord,Num,Enum,Real,Integral,Hashable,Pretty)
+  deriving stock (Eq,Generic, Ord)
+  deriving newtype (Num, Enum, Real, Integral, Hashable, Pretty, FromJSONKey, ToJSONKey)
 instance Show TxKey where show (TxKey k) = show k
 
 type DataTable = Table DataKey
 type TxTable = Table TxKey
 
 newtype TableId = TableId Text
-  deriving (Eq,Show,Ord,IsString,AsString,Hashable, Pretty)
+  deriving stock (Eq,Generic,Show,Ord)
+  deriving newtype (IsString,AsString,Hashable,Pretty)
 
 data Table k where
   DataTable :: !TableId -> DataTable
   TxTable :: !TableId -> TxTable
+instance ToJSON DataTable where
+  toJSON (DataTable (TableId tid)) = object
+    [ "ttype" .= ("data" :: Text)
+    , "tid" .= tid
+    ]
+instance ToJSONKey DataTable
+instance ToJSON TxTable where
+  toJSON (TxTable (TableId tid)) = object
+    [ "ttype" .= ("tx" :: Text)
+    , "tid" .= tid
+    ]
+instance ToJSONKey TxTable
+instance FromJSON DataTable where
+  parseJSON = withObject "DataTable" $ \o -> do
+    "data" :: Text <- o .: "ttype"
+    tid <- o .: "tid"
+    return $ DataTable (TableId tid)
+instance FromJSONKey DataTable
+instance FromJSON TxTable where
+  parseJSON = withObject "TxTable" $ \o -> do
+    "tx" :: Text <- o .: "ttype"
+    tid <- o .: "tid"
+    return $ TxTable (TableId tid)
+instance FromJSONKey TxTable
 
 tableId :: Table k -> TableId
 tableId (DataTable t) = t

src/Pact/Persist/Pure.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -7,6 +8,11 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
 
 module Pact.Persist.Pure
   (
@@ -26,28 +32,45 @@ import Control.Monad.Reader ()
 import Control.Monad.State
 import Data.Default
 import Data.Typeable
+import GHC.Generics
 
 import Pact.Types.Persistence
 import Pact.Persist hiding (compileQuery)
 import Pact.Types.Pretty
 
 import qualified Pact.JSON.Encode as J
+import qualified Data.Text.Encoding as T
 
 newtype Tbl k = Tbl {
   _tbl :: M.Map k B.ByteString
-  } deriving (Show,Semigroup,Monoid)
+  }
+  deriving stock (Eq, Generic, Show)
+  deriving newtype (Semigroup, Monoid)
 makeLenses ''Tbl
+instance (FromJSONKey k, Ord k) => FromJSON (Tbl k) where
+  parseJSON = fmap (Tbl . fmap T.encodeUtf8) . parseJSON
+instance (ToJSONKey k, Ord k) => ToJSON (Tbl k) where
+  toJSON = toJSON . fmap T.decodeUtf8 . _tbl
+
 
 newtype Tables k = Tables {
   _tbls :: M.Map (Table k) (Tbl k)
-  } deriving (Show,Semigroup,Monoid)
+  }
+  deriving stock (Eq, Generic, Show)
+  deriving newtype (Semigroup,Monoid)
 makeLenses ''Tables
+deriving anyclass instance FromJSON (Tables DataKey)
+deriving anyclass instance FromJSON (Tables TxKey)
+deriving anyclass instance ToJSON (Tables DataKey)
+deriving anyclass instance ToJSON (Tables TxKey)
 
 
 data Db = Db {
   _dataTables :: !(Tables DataKey),
   _txTables :: !(Tables TxKey)
-  } deriving (Show)
+  }
+  deriving stock (Eq, Generic, Show)
+  deriving anyclass (FromJSON, ToJSON)
 makeLenses ''Db
 instance Default Db where def = Db mempty mempty
 
@@ -59,6 +82,7 @@ data PureDb = PureDb {
   _committed :: !Db,
   _temp :: !Db
   }
+  deriving stock (Eq, Show)
 makeLenses ''PureDb
 instance Default PureDb where def = PureDb def def
 

src/Pact/Persist/Taped.hs

@@ -0,0 +1,222 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE InstanceSigs #-}
+
+-- |
+-- Module      :  Pact.Persist.Taped
+-- Copyright   :  (C) 2024 Kadena
+-- License     :  BSD-style (see the file LICENSE)
+-- Maintainer  :  Edmund Noble <[email protected]>
+--
+-- Tapes for recording and playing back database access.
+--
+module Pact.Persist.Taped
+  ( WriteSet(..)
+  , reflectingDb
+  , ReflectingDbEnv(..)
+  , reflectingInputMirror
+  , reflectingOutputMirror
+  , reflectingSource
+  , reflectingWriteSet
+  ) where
+
+import Control.Concurrent.MVar
+import Control.Lens
+
+import Data.Default
+import Data.Map (Map)
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Pact.Types.Term
+import Pact.Types.Persistence
+import Control.Monad.State
+import Control.Monad
+import qualified Data.Map as Map
+import Pact.Types.RowData
+import Pact.Types.Lang (Code(..))
+import Pact.Types.Namespace
+import Data.Maybe (isNothing)
+
+data WriteSet
+  = WriteSet
+    { _userTableWrites :: Map TableName (Set RowKey)
+    , _keySetWrites :: Set KeySetName
+    , _moduleWrites :: Set ModuleName
+    , _namespaceWrites :: Set NamespaceName
+    , _defPactWrites :: Set PactId
+    }
+
+instance Semigroup WriteSet where
+  ws <> ws' = WriteSet
+    { _userTableWrites = Map.unionWith Set.union (_userTableWrites ws) (_userTableWrites ws')
+    , _keySetWrites = Set.union (_keySetWrites ws) (_keySetWrites ws')
+    , _moduleWrites = Set.union (_moduleWrites ws) (_moduleWrites ws')
+    , _namespaceWrites = Set.union (_namespaceWrites ws) (_namespaceWrites ws')
+    , _defPactWrites = Set.union (_defPactWrites ws) (_defPactWrites ws')
+    }
+instance Monoid WriteSet where
+  mempty = WriteSet mempty mempty mempty mempty mempty
+
+data ReflectingDbEnv mi mo s = ReflectingDbEnv
+  { _reflectingWriteSet :: !WriteSet
+  , _reflectingInputMirror :: !mi
+  , _reflectingOutputMirror :: !mo
+  , _reflectingSource :: !s
+  }
+
+makeLenses ''ReflectingDbEnv
+
+-- Given inputMirrorDb, outputMirrorDb, and sourceDb, this function creates a PactDb which forwards its read and
+-- write requests to sourceDb, and simultaneously populates inputMirrorDb with enough data to allow re-running
+-- the same requests without the entire source db. It also populates outputMirrorDb with all of the writes made.
+-- Together these allow making small, self-contained tests by:
+-- 1. running Pact transactions on reflectingDb with larger source databases
+-- 2. extracting the mirror databases in JSON format
+-- 3. running the same Pact transactions on reflectingDb with the source set to the original input mirror database
+-- 4. asserting that the final output mirror is equal to the original output mirror
+--
+-- Note: createSchema operates on Persister, which is a layer lower than PactDb;
+-- one must have valid schemas in all database values before using them with reflectingDb.
+reflectingDb :: PactDb mi -> PactDb mo -> PactDb s -> PactDb (ReflectingDbEnv mi mo s)
+reflectingDb inputMirrorDb outputMirrorDb sourceDb = PactDb
+  { _readRow = \d k -> modifyMVarStateT $ do
+      -- when read from, the reflecting db reflects the write from the source to the mirror
+      -- and returns the read value
+      mv <- wrapMethod reflectingSource (_readRow sourceDb d k)
+      createTableForDomainIfMissing reflectingInputMirror inputMirrorDb d
+      WriteSet{..} <- use reflectingWriteSet
+      wrapMethod reflectingInputMirror $ \var -> do
+        -- write to the mirror db only if this row wasn't already written to the source during this transaction
+        () <- case d of
+          UserTables tn
+            | Just tableWrites <- Map.lookup tn _userTableWrites
+            , Set.member k tableWrites -> return ()
+            | otherwise -> forM_ mv $ \v ->
+              _writeRow inputMirrorDb Write d k v var
+          KeySets
+            | Set.member k _keySetWrites -> return ()
+            | otherwise -> forM_ mv $ \v ->
+              _writeRow inputMirrorDb Write d k v var
+          Modules
+            | Set.member k _moduleWrites -> return ()
+            | otherwise -> forM_ mv $ \v ->
+              _writeRow inputMirrorDb Write d k v var
+          Namespaces
+            | Set.member k _namespaceWrites -> return ()
+            | otherwise -> forM_ mv $ \v ->
+              _writeRow inputMirrorDb Write d k v var
+          Pacts
+            | Set.member k _defPactWrites -> return ()
+            | otherwise -> forM_ mv $ \v ->
+              _writeRow inputMirrorDb Write d k v var
+        return ()
+      return mv
+
+  , _writeRow = \wt d k v -> modifyMVarStateT $ do
+      wrapMethod reflectingSource (_writeRow sourceDb wt d k v)
+      createTableForDomainIfMissing reflectingOutputMirror outputMirrorDb d
+      -- we always use Write mode here, because the above write must have succeeded
+      wrapMethod reflectingOutputMirror (_writeRow outputMirrorDb Write d k v)
+      reflectingWriteSet <>= case d of
+        UserTables tn -> mempty { _userTableWrites = Map.singleton tn (Set.singleton k) }
+        KeySets -> mempty { _keySetWrites = Set.singleton k }
+        Modules -> mempty { _moduleWrites = Set.singleton k }
+        Namespaces -> mempty { _namespaceWrites = Set.singleton k }
+        Pacts -> mempty { _defPactWrites = Set.singleton k }
+  , _keys = \d -> modifyMVarStateT $ do
+      ks <- wrapMethod reflectingSource (_keys sourceDb d)
+      createTableForDomainIfMissing reflectingInputMirror inputMirrorDb d
+      -- we have no way of knowing the values at these keys, so we write fake values
+      () <- case d of
+        UserTables tn -> do
+          forM_ ks $ \k -> wrapMethod reflectingInputMirror (_writeRow inputMirrorDb Write (UserTables tn) k
+            RowData { _rdVersion = RDV1, _rdData = ObjectMap mempty })
+        KeySets -> do
+          forM_ ks $ \k -> wrapMethod reflectingInputMirror (_writeRow inputMirrorDb Write KeySets k
+            KeySet { _ksKeys = mempty, _ksPredFun = Name $ BareName "fake" def })
+        Modules -> do
+          forM_ ks $ \k ->
+            wrapMethod reflectingInputMirror
+              (_writeRow inputMirrorDb Write Modules k
+                (ModuleData (MDInterface (Interface "fake" (Code "") (Meta Nothing []) []) ) mempty mempty))
+        Namespaces -> do
+          forM_ ks $ \k ->
+            wrapMethod reflectingInputMirror
+              (_writeRow inputMirrorDb Write Namespaces k
+                (Namespace (NamespaceName "fake") (GKeySetRef "fake") (GKeySetRef "fake")))
+        Pacts -> do
+          forM_ ks $ \k ->
+            wrapMethod reflectingInputMirror (_writeRow inputMirrorDb Write Pacts k Nothing)
+
+      return ks
+
+  , _txids = \tn txid -> modifyMVarStateT $ wrapMethod reflectingSource (_txids sourceDb tn txid)
+  , _createUserTable = \tn mn -> modifyMVarStateT $ do
+      wrapMethod reflectingSource (_createUserTable sourceDb tn mn)
+      wrapMethod reflectingOutputMirror (_createUserTable outputMirrorDb tn mn)
+
+  , _getUserTableInfo = \tn -> modifyMVarStateT $ wrapMethod reflectingSource (_getUserTableInfo sourceDb tn)
+  , _beginTx = \em -> modifyMVarStateT $ do
+    txid <- wrapMethod reflectingSource (_beginTx sourceDb em)
+    _ <- wrapMethod reflectingInputMirror (_beginTx inputMirrorDb em)
+    _ <- wrapMethod reflectingOutputMirror (_beginTx outputMirrorDb em)
+    return txid
+  , _commitTx = modifyMVarStateT $ do
+    logs <- wrapMethod reflectingSource (_commitTx sourceDb)
+    _ <- wrapMethod reflectingInputMirror (_commitTx inputMirrorDb)
+    _ <- wrapMethod reflectingOutputMirror (_commitTx outputMirrorDb)
+    -- reset write set outside of transaction
+    reflectingWriteSet .= mempty
+    return logs
+  , _rollbackTx = modifyMVarStateT $ do
+    wrapMethod reflectingSource (_rollbackTx sourceDb)
+    -- we commit to the mirror databases even on a rollback, to allow observing even failed txs
+    _ <- wrapMethod reflectingInputMirror (_commitTx inputMirrorDb)
+    _ <- wrapMethod reflectingOutputMirror (_commitTx outputMirrorDb)
+    -- reset write set outside of transaction
+    reflectingWriteSet .= mempty
+  , _getTxLog = \d txid -> modifyMVarStateT $ do
+    wrapMethod reflectingSource (_getTxLog sourceDb d txid)
+  }
+  where
+  wrapMethod :: Lens' s a -> (MVar a -> IO r) -> StateT s IO r
+  wrapMethod l m = do
+    v <- get
+    var <- liftIO $ newMVar (v ^. l)
+    r <- liftIO $ m var
+    v' <- liftIO $ takeMVar var
+    put (v & l .~ v')
+    return r
+
+  modifyMVarStateT act var = do
+    modifyMVar var $ \v -> do
+      (a, v') <- runStateT act v
+      return (v', a)
+
+  createTableForDomainIfMissing :: Lens' s a -> PactDb a -> Domain k v -> StateT s IO ()
+  createTableForDomainIfMissing l db d = wrapMethod l $ \var ->
+    -- create a user table for this write if missing, do this even if the value
+    -- itself is Nothing, to avoid missing table errors
+    case d of
+      UserTables tn -> do
+        tableModule <- _getUserTableInfo db tn var
+        when (isNothing tableModule) $
+          _createUserTable db tn "fake module name" var
+      _ -> return ()