Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

feature: support for reflecting db contents into another db #1366

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion docs/en/pact-functions.md
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down
1 change: 1 addition & 0 deletions pact.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -128,6 +128,7 @@ library
Pact.Persist.MockPersist
Pact.Persist.Pure
Pact.Persist.SQLite
Pact.Persist.Taped
Pact.PersistPactDb
Pact.PersistPactDb.Regression
Pact.Repl
Expand Down
4 changes: 2 additions & 2 deletions src/Pact/MockDb.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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])
Expand Down
38 changes: 35 additions & 3 deletions src/Pact/Persist.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,10 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Pact.Persist
(Persist,
Expand All @@ -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
Expand Down
30 changes: 27 additions & 3 deletions src/Pact/Persist/Pure.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
Expand All @@ -7,6 +8,11 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}

module Pact.Persist.Pure
(
Expand All @@ -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

Expand All @@ -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

Expand Down
222 changes: 222 additions & 0 deletions src/Pact/Persist/Taped.hs
Original file line number Diff line number Diff line change
@@ -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 <edmund@kadena.io>
--
-- 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 ()
Loading
Loading