From 1ffbfdc5b5d31415674800a70d8929f82f0bb48b Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Tue, 7 May 2024 10:11:49 -0400 Subject: [PATCH] tapes Change-Id: I0564ed8cfcbec9aaea6d980c586723367e34f0e9 --- pact.cabal | 1 + src/Pact/Persist/Taped.hs | 275 ++++++++++++++++++++++++++++++++++ src/Pact/Types/Persistence.hs | 73 ++++++++- src/Pact/Types/Runtime.hs | 29 +++- 4 files changed, 364 insertions(+), 14 deletions(-) create mode 100644 src/Pact/Persist/Taped.hs diff --git a/pact.cabal b/pact.cabal index 84b61c365..b533f22e3 100644 --- a/pact.cabal +++ b/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 diff --git a/src/Pact/Persist/Taped.hs b/src/Pact/Persist/Taped.hs new file mode 100644 index 000000000..0e2b4c29e --- /dev/null +++ b/src/Pact/Persist/Taped.hs @@ -0,0 +1,275 @@ +{-# 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 +-- +-- Tapes for recording and playing back database access. +-- +module Pact.Persist.Taped ( + TxTapeElem(..), + TxTape(..), + _TxTape, + TxTapeZipper(..), + dbFromTape + ) + where + +import Control.Concurrent.MVar +import Control.DeepSeq (NFData(..)) +import Control.Exception.Safe +import Control.Lens + +import Data.Default +import Data.Maybe +import GHC.Generics (Generic) + +import Pact.Types.PactError +import Pact.Types.Pretty +import Pact.Types.Term +import Pact.Types.Persistence +import qualified Pact.JSON.Encode as J +import Data.Aeson +import Data.Text (Text) + +-- Other operations not stored on tape because they're not available outside +-- the repl and local modes. +data TxTapeElem + = forall k v. TxTapeWrite !WriteType !(Domain k v) !k !v + | forall k v. TxTapeRead !(Domain k v) !k !(Maybe v) + | forall k v. TxTapeKeys !(Domain k v) ![k] + | TxTapeCreateTable !TableName !ModuleName + +instance NFData TxTapeElem where + rnf (TxTapeWrite wt d k v) = constraintsForDomain d $ + rnf wt `seq` rnf d `seq` rnf k `seq` rnf v + rnf (TxTapeRead d k v) = constraintsForDomain d $ + rnf d `seq` rnf k `seq` rnf v + rnf (TxTapeKeys d ks) = constraintsForDomain d $ + rnf d `seq` rnf d `seq` rnf ks + rnf (TxTapeCreateTable tn mn) = + rnf tn `seq` rnf mn + +newtype TxTape = TxTape [TxTapeElem] + deriving (Generic) + deriving newtype (Show, NFData) + +instance Show TxTapeElem where + showsPrec :: Int -> TxTapeElem -> ShowS + showsPrec p (TxTapeWrite wt d k v) = constraintsForDomain d $ + showParen (p > 10) + $ showString "Write " + . foldr (\x r -> x . showString " " . r) id + [ showsPrec 11 wt + , showsPrec 11 d + , showsPrec 11 k + , showsPrec 11 v + ] + showsPrec p (TxTapeRead d k mv) = constraintsForDomain d $ + showParen (p > 10) + $ showString "Read " + . foldr (\x r -> x . showString " " . r) id + [ showsPrec 11 d + , showsPrec 11 k + , showsPrec 11 mv + ] + showsPrec p (TxTapeKeys d ks) = constraintsForDomain d $ + showParen (p > 10) + $ showString "Keys " + . foldr (\x r -> x . showString " " . r) id + [ showsPrec 11 d + , showsPrec 11 ks + ] + showsPrec p (TxTapeCreateTable tn mn) = + showParen (p > 10) + $ showString "CreateTable " + . foldr (\x r -> x . showString " " . r) id + [ showsPrec 11 tn + , showsPrec 11 mn + ] + +makePrisms ''TxTape + +data TxTapeZipper = TxTapeZipper !TxTape !(Maybe TxTapeElem) !TxTape + +dbFromTape :: PactDb TxTapeZipper +dbFromTape = PactDb + { _readRow = \d k var -> modifyTape var $ doOperation "read" $ \case + TxTapeRead d' k' mv -> do + checkDomain "read" d d' $ do + checkAll mv $ catMaybes + [ check "key" k k' + ] + otherOperation -> mismatchedOperation "read" otherOperation + + , _writeRow = \wt d k v var -> modifyTape var $ doOperation "write" $ \case + TxTapeWrite wt' d' k' v' -> do + checkDomain "write" d d' $ do + checkAll () $ catMaybes + [ check "key" k k' + , check "value" v v' + , check "write type" wt wt' + ] + otherOperation -> mismatchedOperation "write" otherOperation + + , _keys = \d var -> modifyTape var $ doOperation "keys" $ \case + TxTapeKeys d' ks -> + checkDomain "keys" d d' $ return ks + otherOperation -> mismatchedOperation "keys" otherOperation + + , _txids = \_ _ _ -> unsupportedOperation "_txids" + , _createUserTable = \tn mn var -> modifyTape var $ doOperation "create user table" $ \case + TxTapeCreateTable tn' mn' -> do + checkAll () $ catMaybes + [ check "table name" tn tn' + , check "module name" mn mn' + ] + otherOperation -> mismatchedOperation "create user table" otherOperation + , _getUserTableInfo = \_ _ -> unsupportedOperation "_getUserTableInfo" + , _beginTx = \_ _ -> unsupportedOperation "_beginTx" + , _commitTx = \_ -> unsupportedOperation "_commitTx" + , _rollbackTx = \_ -> unsupportedOperation "_rollbackTx" + , _getTxLog = \_ _ _ -> unsupportedOperation "_getTxLog" + } + where + unsupportedOperation operationName = + throwEvalError $ "dbFromTape: unsupported operation " <> operationName + mismatchedOperation :: String -> TxTapeElem -> IO r + mismatchedOperation actualOp expectedOp = throwEvalError $ unwords + [ "dbFromTape: attempted to", actualOp, "but next operation on tape was", show expectedOp ] + throwEvalError :: String -> IO r + throwEvalError msg = throwM $ PactError DbError def [] $ pretty msg + checkDomain + :: String + -> Domain k1 v1 + -> Domain k2 v2 + -> ((k1 ~ k2, v1 ~ v2, Show k1, Eq k1, Show v1, Eq v1) => IO r) + -> IO r + checkDomain operation domainActual domainExpected r = + constraintsForDomain domainActual $ + case (domainActual, domainExpected) of + (UserTables tnActual, UserTables tnExpected) + | tnActual == tnExpected -> r + (KeySets, KeySets) -> r + (Modules, Modules) -> r + (Namespaces, Namespaces) -> r + (Pacts, Pacts) -> r + _ -> throwEvalError + $ unlines + [ "dbFromTape: tape mismatch" + , "operation " <> operation + , unwords ["domain", "actual", show domainActual, "expected", show domainExpected] + ] + check :: (Show a, Eq a) => String -> a -> a -> Maybe String + check name actual expected + | actual == expected = Nothing + | otherwise = Just $ unwords [name, "actual", show actual, "expected", show expected] + checkAll :: r -> [String] -> IO r + checkAll r [] = return r + checkAll _ errs = throwEvalError $ unlines $ "dbFromTape: tape mismatch" : errs + modifyTape + :: MVar TxTapeZipper + -> (TxTapeZipper -> IO (TxTapeZipper, a)) + -> IO a + modifyTape var k = do + modifyMVar var $ \tape -> do + (tape', r) <- k tape + return (tape', r) + doOperation :: String -> (TxTapeElem -> IO a) -> TxTapeZipper -> IO (TxTapeZipper, a) + doOperation msg _ (TxTapeZipper _ Nothing _) = + throwEvalError $ "dbFromTape: attempted " <> msg <> " beyond tape's end" + doOperation _ g (TxTapeZipper (TxTape l) (Just c) r) = do + res <- g c + return $ (,res) $ case r of + TxTape (c' : r') -> + TxTapeZipper (TxTape (c : l)) (Just c') (TxTape r') + TxTape [] -> + TxTapeZipper (TxTape (c : l)) Nothing (TxTape []) + +domainToJSON :: Domain k v -> [J.KeyValue] +domainToJSON (UserTables (TableName tn)) = + [ J.KeyValue "domain" (J.text "userTable") + , J.KeyValue "userTable" (J.build tn) + ] +domainToJSON KeySets = [J.KeyValue "domain" (J.text "keysets")] +domainToJSON Modules = [J.KeyValue "domain" (J.text "modules")] +domainToJSON Namespaces = [J.KeyValue "domain" (J.text "namespaces")] +domainToJSON Pacts = [J.KeyValue "domain" (J.text "pacts")] + +instance J.Encode TxTapeElem where + build (TxTapeWrite wt d k v) = constraintsForDomain d $ + J.build $ J.Object $ + [ J.KeyValue "op" (J.text "write") + , J.KeyValue "writeType" (J.build wt) + , J.KeyValue "key" (J.build k) + , J.KeyValue "value" (J.build v) + ] ++ domainToJSON d + build (TxTapeRead d k mv) = constraintsForDomain d $ + J.build $ J.Object $ + [ J.KeyValue "op" (J.text "read") + , J.KeyValue "key" (J.build k) + , J.KeyValue "value" (maybe J.null J.build mv) + ] ++ domainToJSON d + build (TxTapeKeys d ks) = constraintsForDomain d $ + J.build $ J.Object $ + [ J.KeyValue "op" (J.text "keys") + , J.KeyValue "keys" (J.build $ J.Array $ J.build <$> ks) + ] ++ domainToJSON d + build (TxTapeCreateTable tn mn) = J.build $ J.Object $ + [ J.KeyValue "op" (J.text "createTable") + , J.KeyValue "tableName" (J.build tn) + , J.KeyValue "moduleName" (J.build mn) + ] + +instance FromJSON TxTapeElem where + parseJSON = withObject "TxTapeElem" $ \o -> do + operation <- o .: "op" + case operation :: Text of + "write" -> parseWrite o + "read" -> parseRead o + "keys" -> parseKeys o + "createTable" -> parseCreateTable o + _ -> fail "invalid op, expected write, read, keys, or createTable" + where + parseWrite o = + o .: "domain" >>= \case + SomeDomain d -> constraintsForDomain d $ do + wt <- o .: "writeType" + k <- o .: "key" + v <- o .: "value" + return $ TxTapeWrite wt d k v + parseRead o = + o .: "domain" >>= \case + SomeDomain d -> constraintsForDomain d $ do + k <- o .: "key" + mv <- o .: "value" + return $ TxTapeRead d k mv + parseKeys o = + o .: "domain" >>= \case + SomeDomain d -> constraintsForDomain d $ do + ks <- o .: "keys" + return $ TxTapeKeys d ks + parseCreateTable o = do + tn <- o .: "tableName" + mn <- o .: "moduleName" + return $ TxTapeCreateTable tn mn diff --git a/src/Pact/Types/Persistence.hs b/src/Pact/Types/Persistence.hs index 3ef231ceb..8fc6708ab 100644 --- a/src/Pact/Types/Persistence.hs +++ b/src/Pact/Types/Persistence.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -10,9 +11,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE InstanceSigs #-} -- | -- Module : Pact.Types.Persistence @@ -26,6 +30,8 @@ module Pact.Types.Persistence ( RowKey(..), Domain(..), + SomeDomain(..), + constraintsForDomain, TxLog(..),txDomain,txKey,txValue, TxLogRaw, RawTxLogData(..), @@ -45,19 +51,19 @@ module Pact.Types.Persistence ) where import Control.Applicative ((<|>)) -import Control.Concurrent.MVar (MVar) -import Control.DeepSeq (NFData) -import Control.Lens (makeLenses) +import Control.Concurrent.MVar +import Control.DeepSeq (NFData(..)) +import Control.Exception.Safe +import Control.Lens import Data.Aeson hiding (Object) import Data.Default import qualified Data.ByteString as B import Data.Hashable (Hashable) -import Data.Maybe(fromMaybe) +import Data.Maybe import qualified Data.HashMap.Strict as HM import Data.String (IsString(..)) import Data.Text (Text, pack) -import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics (Generic) @@ -75,6 +81,7 @@ import Pact.Types.Namespace import Pact.JSON.Legacy.Utils import qualified Pact.JSON.Legacy.HashMap as LHM import qualified Pact.JSON.Encode as J +import Control.Monad (unless) -- -------------------------------------------------------------------------- -- -- PersistDirect @@ -191,7 +198,7 @@ instance FromJSON (Ref' PersistDirect) where -- | Row key type for user tables. newtype RowKey = RowKey Text deriving (Eq,Ord,Generic) - deriving newtype (IsString,ToTerm,AsString,Show,Pretty,NFData) + deriving newtype (IsString,ToTerm,AsString,Show,Pretty,NFData,J.Encode,FromJSON) instance Arbitrary RowKey where arbitrary = RowKey <$> arbitrary @@ -221,6 +228,46 @@ instance AsString (Domain k v) where asString Modules = "SYS:Modules" asString Namespaces = "SYS:Namespaces" asString Pacts = "SYS:Pacts" +instance NFData (Domain k v) where + rnf (UserTables tn) = rnf tn + rnf KeySets = () + rnf Modules = () + rnf Namespaces = () + rnf Pacts = () + +data SomeDomain = forall k v. SomeDomain (Domain k v) +instance J.Encode SomeDomain where + build (SomeDomain d) = case d of + UserTables tn -> J.build $ J.Object + [ J.KeyValue "tag" $ J.text "UserTables" + , J.KeyValue "tableName" $ J.build tn + ] + KeySets -> J.text "KeySets" + Modules -> J.text "Modules" + Namespaces -> J.text "Namespaces" + Pacts -> J.text "Pacts" +instance FromJSON SomeDomain where + parseJSON v = + (withText "Domain" $ \case + "KeySets" -> return $ SomeDomain KeySets + "Modules" -> return $ SomeDomain Modules + "Namespaces" -> return $ SomeDomain Namespaces + "Pacts" -> return $ SomeDomain Pacts + _ -> fail "invalid Domain") v <|> + (withObject "Domain" $ \o -> do + tag :: Text <- o .: "tag" + unless (tag == "UserTables") $ + fail "JSON object Domain must have UserTables tag" + tableName <- o .: "tableName" + return $ SomeDomain (UserTables tableName) + ) v + +constraintsForDomain :: Domain k v -> ((Show k, Show v, Eq k, Eq v, NFData k, NFData v, J.Encode k, J.Encode v, FromJSON k, FromJSON v) => r) -> r +constraintsForDomain (UserTables _) r = r +constraintsForDomain KeySets r = r +constraintsForDomain Modules r = r +constraintsForDomain Namespaces r = r +constraintsForDomain Pacts r = r -- -------------------------------------------------------------------------- -- -- TxLog @@ -329,7 +376,19 @@ data WriteType = -- | Update an existing row, or insert a new row if not found. -- Requires complete row value, enforced by pact runtime. Write - deriving (Eq,Ord,Show,Enum,Bounded) + deriving (Eq,Ord,Show,Enum,Bounded,Generic,NFData) + +instance J.Encode WriteType where + build Insert = J.text "Insert" + build Update = J.text "Update" + build Write = J.text "Write" + +instance FromJSON WriteType where + parseJSON = withText "WriteType" $ \case + "Insert" -> return Insert + "Update" -> return Update + "Write" -> return Write + _ -> fail "invalid, expected Insert, Update, or Write" instance Pretty WriteType where pretty g = case g of diff --git a/src/Pact/Types/Runtime.hs b/src/Pact/Types/Runtime.hs index 72525cba6..23a40a059 100644 --- a/src/Pact/Types/Runtime.hs +++ b/src/Pact/Types/Runtime.hs @@ -37,7 +37,7 @@ module Pact.Types.Runtime Purity(..), RefState(..),rsLoaded,rsLoadedModules,rsNamespace,rsQualifiedDeps, EvalState(..),evalRefs,evalCallStack,evalPactExec, - evalCapabilities,evalLogGas,evalEvents,evalUserCapabilitiesBeingEvaluated, + evalCapabilities,evalLogGas,evalTxTape,evalEvents,evalUserCapabilitiesBeingEvaluated, Eval(..),runEval,runEval',catchesPactError, call,method, readRow,writeRow,keys,txids,createUserTable,getUserTableInfo,beginTx,commitTx,rollbackTx,getTxLog, @@ -83,6 +83,7 @@ import Data.Set(Set) import GHC.Generics (Generic) import Test.QuickCheck +import Pact.Persist.Taped import Pact.Types.Term import Pact.Types.Capability import Pact.Types.ChainMeta @@ -368,10 +369,12 @@ data EvalState = EvalState { , _evalLogGas :: !(Maybe [(Text,Gas)]) -- | Accumulate events , _evalEvents :: ![PactEvent] + -- | Recording of database access + , _evalTxTape :: !(Maybe TxTape) } deriving (Show, Generic) makeLenses ''EvalState instance NFData EvalState -instance Default EvalState where def = EvalState def def def def def def def +instance Default EvalState where def = EvalState def def def def def def def def -- | Interpreter monad, parameterized over back-end MVar state type. newtype Eval e a = @@ -442,16 +445,26 @@ emitPactWarning pw = -- -- | Invoke '_readRow' -readRow :: (IsString k,FromJSON v) => Info -> Domain k v -> k -> Eval e (Maybe v) -readRow i d k = method i $ \db -> _readRow db d k +readRow + :: (IsString k, FromJSON v) + => Info -> Domain k v -> k -> Eval e (Maybe v) +readRow i d k = do + mv <- method i $ \db -> _readRow db d k + evalTxTape . _Just . _TxTape %= (TxTapeRead d k mv :) + return mv -- | Invoke '_writeRow' writeRow :: (AsString k,J.Encode v) => Info -> WriteType -> Domain k v -> k -> v -> Eval e () -writeRow i w d k v = method i $ \db -> _writeRow db w d k v +writeRow i wt d k v = do + method i $ \db -> _writeRow db wt d k v + evalTxTape . _Just . _TxTape %= (TxTapeWrite wt d k v :) -- | Invoke '_keys' keys :: (AsString k,IsString k) => Info -> Domain k v -> Eval e [k] -keys i t = method i $ \db -> _keys db t +keys i d = do + ks <- method i $ \db -> _keys db d + evalTxTape . _Just . _TxTape %= (TxTapeKeys d ks :) + return ks -- | Invoke '_txids' txids :: Info -> TableName -> TxId -> Eval e [TxId] @@ -459,7 +472,9 @@ txids i tn tid = method i $ \db -> _txids db tn tid -- | Invoke '_createUserTable' createUserTable :: Info -> TableName -> ModuleName -> Eval e () -createUserTable i t m = method i $ \db -> _createUserTable db t m +createUserTable i tn mn = do + method i $ \db -> _createUserTable db tn mn + evalTxTape . _Just . _TxTape %= (TxTapeCreateTable tn mn :) -- | Invoke _getUserTableInfo getUserTableInfo :: Info -> TableName -> Eval e ModuleName