Delete sql savepoints from Pact PP, use sql transactions

It seems that since adding the read-only connection pool we get misuse
errors from sqlite occasionally when releasing savepoints. I can't tell
how exactly savepoints are implemented, and there is no sqlite
documentation on the interaction between multiple readers and savepoints
for read transactions and the WAL file all together, *but*, the simple
policy that transactions are only begun from PactService.hs seems
sufficient to give us the same guarantees as we got from savepoints
anyway.

Change-Id: Id000000058775f60cd5949497a34d0fb06584190

Author: edmundnoble

src/Chainweb/Pact/Backend/ChainwebPactDb.hs

@@ -45,7 +45,7 @@
 -- |                     +v--------------------------------------------+   +v----------------------------------------------+ |
 -- |                      Pact5Db tx                                        Pact5Db tx                                       |
 -- +v------------------------------------------------------------------------------------------------------------------------+
---  SQLite tx (withSavepoint)
+--  SQLite tx (withTransaction)
 --    (in some cases multiple blocks in tx)
 --
 --
@@ -763,19 +763,18 @@ createVersionedTable tablename db = do
 
 setConsensusState :: SQ3.Database -> ConsensusState -> ExceptT LocatedSQ3Error IO ()
 setConsensusState db cs = do
-    withSavepoint db SetConsensusSavePoint $ do
-        exec' db
-            "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
-            \(?, ?, ?, ?);"
-            (toRow "final" $ _consensusStateFinal cs)
-        exec' db
-            "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
-            \(?, ?, ?, ?);"
-            (toRow "safe" $ _consensusStateSafe cs)
-        exec' db
-            "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
-            \(?, ?, ?, ?);"
-            (toRow "latest" $ _consensusStateLatest cs)
+    exec' db
+        "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
+        \(?, ?, ?, ?);"
+        (toRow "final" $ _consensusStateFinal cs)
+    exec' db
+        "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
+        \(?, ?, ?, ?);"
+        (toRow "safe" $ _consensusStateSafe cs)
+    exec' db
+        "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
+        \(?, ?, ?, ?);"
+        (toRow "latest" $ _consensusStateLatest cs)
     where
     toRow safety SyncState {..} =
         [ SInt $ fromIntegral @BlockHeight @Int64 _syncStateHeight
@@ -816,18 +815,17 @@ getConsensusState db = do
 -- | Create all tables that exist pre-genesis
 -- TODO: migrate this logic to the checkpointer itself?
 initSchema :: SQLiteEnv -> IO ()
-initSchema sql =
-    withSavepoint sql InitSchemaSavePoint $ throwOnDbError $ do
-        createConsensusStateTable
-        createBlockHistoryTable
-        createTableCreationTable
-        createTableMutationTable
-        createTransactionIndexTable
-        create (toUtf8 $ Pact.renderDomain Pact.DKeySets)
-        create (toUtf8 $ Pact.renderDomain Pact.DModules)
-        create (toUtf8 $ Pact.renderDomain Pact.DNamespaces)
-        create (toUtf8 $ Pact.renderDomain Pact.DDefPacts)
-        create (toUtf8 $ Pact.renderDomain Pact.DModuleSource)
+initSchema sql = throwOnDbError $ do
+    createConsensusStateTable
+    createBlockHistoryTable
+    createTableCreationTable
+    createTableMutationTable
+    createTransactionIndexTable
+    create (toUtf8 $ Pact.renderDomain Pact.DKeySets)
+    create (toUtf8 $ Pact.renderDomain Pact.DModules)
+    create (toUtf8 $ Pact.renderDomain Pact.DNamespaces)
+    create (toUtf8 $ Pact.renderDomain Pact.DDefPacts)
+    create (toUtf8 $ Pact.renderDomain Pact.DModuleSource)
     where
     create tablename = do
         createVersionedTable tablename sql

src/Chainweb/Pact/Backend/Utils.hs

@@ -37,14 +37,12 @@ module Chainweb.Pact.Backend.Utils
   , rewindDbToBlock
   , rewindDbToGenesis
   , getEndTxId
-    -- * Savepoints
-  , withSavepoint
-  , SavepointName(..)
+    -- * Transactions
+  , withTransaction
   -- * SQLite conversions and assertions
   , toUtf8
   , fromUtf8
   , asStringUtf8
-  , convSavepointName
   -- * SQLite runners
   , withSqliteDb
   , withReadSqlitePool
@@ -147,88 +145,29 @@ asStringUtf8 = toUtf8 . asString
 -- -------------------------------------------------------------------------- --
 --
 
-withSavepoint
+withTransaction
     :: (HasCallStack, MonadMask m, MonadIO m)
     => SQLiteEnv
-    -> SavepointName
     -> m a
     -> m a
-withSavepoint db name action = fmap fst $ generalBracket
-    (liftIO $ beginSavepoint db name)
+withTransaction db action = fmap fst $ generalBracket
+    (liftIO $ beginTransaction db)
     (\_ -> liftIO . \case
-        ExitCaseSuccess {} -> commitSavepoint db name
-        _ -> abortSavepoint db name
+        ExitCaseSuccess {} -> commitTransaction db
+        _ -> rollbackTransaction db
     ) $ \_ -> action
 
-beginSavepoint :: HasCallStack => SQLiteEnv -> SavepointName -> IO ()
-beginSavepoint db name =
-  throwOnDbError $ exec_ db $ "SAVEPOINT [" <> convSavepointName name <> "];"
+beginTransaction :: HasCallStack => SQLiteEnv -> IO ()
+beginTransaction db =
+  throwOnDbError $ exec_ db $ "BEGIN TRANSACTION;"
 
-commitSavepoint :: HasCallStack => SQLiteEnv -> SavepointName -> IO ()
-commitSavepoint db name =
-  throwOnDbError $ exec_ db $ "RELEASE SAVEPOINT [" <> convSavepointName name <> "];"
+commitTransaction :: HasCallStack => SQLiteEnv -> IO ()
+commitTransaction db =
+  throwOnDbError $ exec_ db $ "COMMIT TRANSACTION;"
 
-convSavepointName :: SavepointName -> SQ3.Utf8
-convSavepointName = toUtf8 . toText
-
--- | @rollbackSavepoint n@ rolls back all database updates since the most recent
--- savepoint with the name @n@ and restarts the transaction.
---
--- /NOTE/ that the savepoint is not removed from the savepoint stack. In order to
--- also remove the savepoint @rollbackSavepoint n >> commitSavepoint n@ can be
--- used to release the (empty) transaction.
---
--- Cf. <https://www.sqlite.org/lang_savepoint.html> for details about
--- savepoints.
---
-rollbackSavepoint :: HasCallStack => SQLiteEnv -> SavepointName -> IO ()
-rollbackSavepoint db name =
-  throwOnDbError $ exec_ db $ "ROLLBACK TRANSACTION TO SAVEPOINT [" <> convSavepointName name <> "];"
-
--- | @abortSavepoint n@ rolls back all database updates since the most recent
--- savepoint with the name @n@ and removes it from the savepoint stack.
-abortSavepoint :: HasCallStack => SQLiteEnv -> SavepointName -> IO ()
-abortSavepoint db name = do
-  rollbackSavepoint db name
-  commitSavepoint db name
-
-data SavepointName
-    = ReadFromSavepoint
-    | ReadFromNSavepoint
-    | RestoreAndSaveSavePoint
-    | RewindSavePoint
-    | InitSchemaSavePoint
-    | ValidateBlockSavePoint
-    | SetConsensusSavePoint
-    | RunGenesisSavePoint
-    deriving (Eq, Ord, Enum, Bounded)
-
-instance Show SavepointName where
-    show = T.unpack . toText
-
-instance HasTextRepresentation SavepointName where
-    toText ReadFromSavepoint = "read-from"
-    toText ReadFromNSavepoint = "read-from-n"
-    toText RestoreAndSaveSavePoint = "restore-and-save"
-    toText RewindSavePoint = "rewind"
-    toText InitSchemaSavePoint = "init-schema"
-    toText ValidateBlockSavePoint = "validate-block"
-    toText SetConsensusSavePoint = "set-consensus"
-    toText RunGenesisSavePoint = "run-genesis"
-    {-# INLINE toText #-}
-
-    fromText "read-from" = pure ReadFromSavepoint
-    fromText "read-from-n" = pure ReadFromNSavepoint
-    fromText "restore-and-save" = pure RestoreAndSaveSavePoint
-    fromText "rewind" = pure RewindSavePoint
-    fromText "init-schema" = pure InitSchemaSavePoint
-    fromText "validate-block" = pure ValidateBlockSavePoint
-    fromText "set-consensus" = pure SetConsensusSavePoint
-    fromText "run-genesis" = pure RunGenesisSavePoint
-    fromText t = throwM $ TextFormatException
-        $ "failed to decode SavepointName " <> t
-        <> ". Valid names are " <> T.intercalate ", " (toText @SavepointName <$> [minBound .. maxBound])
-    {-# INLINE fromText #-}
+rollbackTransaction :: HasCallStack => SQLiteEnv -> IO ()
+rollbackTransaction db =
+  throwOnDbError $ exec_ db $ "ROLLBACK TRANSACTION;"
 
 chainwebPragmas :: [Pact4.Pragma]
 chainwebPragmas =

src/Chainweb/Pact/PactService.hs

@@ -52,7 +52,7 @@ import Chainweb.Miner.Pact
 import Chainweb.Pact.Backend.ChainwebPactDb qualified as ChainwebPactDb
 import Chainweb.Pact.Backend.ChainwebPactDb qualified as Pact
 import Chainweb.Pact.Backend.Types
-import Chainweb.Pact.Backend.Utils (withSavepoint, SavepointName (..))
+import Chainweb.Pact.Backend.Utils (withTransaction)
 import Chainweb.Pact.NoCoinbase qualified as Pact
 import Chainweb.Pact.PactService.Checkpointer qualified as Checkpointer
 import Chainweb.Pact.PactService.ExecBlock
@@ -140,7 +140,8 @@ withPactService cid http memPoolAccess chainwebLogger txFailuresCounter pdb read
             traverse_ cancel refresherThread
         )
 
-    liftIO $ ChainwebPactDb.initSchema readWriteSqlenv
+    liftIO $ withTransaction readWriteSqlenv $
+        ChainwebPactDb.initSchema readWriteSqlenv
     candidatePdb <- liftIO MapTable.emptyTable
     moduleInitCacheVar <- liftIO $ newMVar mempty
 
@@ -194,7 +195,7 @@ runGenesisIfNeeded
     -> ServiceEnv tbl
     -> IO ()
 runGenesisIfNeeded logger serviceEnv = do
-    withSavepoint (_psReadWriteSql serviceEnv) RunGenesisSavePoint $ do
+    withTransaction (_psReadWriteSql serviceEnv) $ do
         latestBlock <- fmap _consensusStateLatest <$> Checkpointer.getConsensusState (_psReadWriteSql serviceEnv)
         when (maybe True (isGenesisBlockHeader' cid . Parent . _syncStateBlockHash) latestBlock) $ do
             logFunctionText logger Debug "running genesis"
@@ -262,7 +263,7 @@ execNewGenesisBlock
     -> ServiceEnv tbl
     -> Vector Pact.Transaction
     -> IO PayloadWithOutputs
-execNewGenesisBlock logger serviceEnv newTrans = do
+execNewGenesisBlock logger serviceEnv newTrans = withTransaction (_psReadWriteSql serviceEnv) $ do
     let cid = _chainId serviceEnv
     let parentCreationTime = Parent (implicitVersion ^?! versionGenesis . genesisTime . atChain cid)
     historicalBlock <- Checkpointer.readFrom logger cid (_psReadWriteSql serviceEnv) parentCreationTime
@@ -328,7 +329,7 @@ execReadOnlyReplay logger serviceEnv blocks = do
             let isPayloadEmpty = V.null (_payloadWithOutputsTransactions payload)
             let isUpgradeBlock = isJust $ implicitVersion ^? versionUpgrades . atChain cid . ix (_evaluationCtxCurrentHeight evalCtx)
             if isPayloadEmpty && not isUpgradeBlock
-            then Pool.withResource readSqlPool $ \sql -> do
+            then Pool.withResource readSqlPool $ \sql -> withTransaction sql $ do
                 hist <- Checkpointer.readFrom
                     logger
                     cid
@@ -372,7 +373,7 @@ execLocal logger serviceEnv cwtx preflight sigVerify rdepth = do
                 pure $ Historical LocalTimeout
     where
 
-    doLocal = Pool.withResource (view psReadSqlPool serviceEnv) $ \sql -> do
+    doLocal = Pool.withResource (view psReadSqlPool serviceEnv) $ \sql -> withTransaction sql $ do
         fakeNewBlockCtx <- liftIO Checkpointer.mkFakeParentCreationTime
         Checkpointer.readFromNthParent logger cid sql fakeNewBlockCtx (fromIntegral rewindDepth)
             $ Checkpointer.readPact5 "Pact 4 cannot execute local calls" $ \blockEnv blockHandle -> do
@@ -505,7 +506,7 @@ syncToFork
     -> ForkInfo
     -> IO ConsensusState
 syncToFork logger serviceEnv hints forkInfo = do
-    (rewoundTxs, validatedTxs, newConsensusState) <- withSavepoint sql ValidateBlockSavePoint $ do
+    (rewoundTxs, validatedTxs, newConsensusState) <- withTransaction sql $ do
         pactConsensusState <- fromJuste <$> Checkpointer.getConsensusState sql
         let atTarget =
                 _syncStateBlockHash (_consensusStateLatest pactConsensusState) ==
@@ -719,13 +720,15 @@ refreshPayloads logger serviceEnv = do
     logFunctionText logger Debug $
         "refreshing payloads for " <>
         brief (_bctxParentRankedBlockHash $ _blockInProgressBlockCtx blockInProgress)
-    maybeRefreshedBlockInProgress <- Pool.withResource (view psReadSqlPool serviceEnv) $ \sql ->
-        Checkpointer.readFrom logger cid sql
-            (_bctxParentCreationTime $ _blockInProgressBlockCtx blockInProgress)
-            (_bctxParentRankedBlockHash $ _blockInProgressBlockCtx blockInProgress)
-            $ Checkpointer.readPact5 "Pact 4 cannot make new blocks" $ \blockEnv _bh -> do
-                let dbEnv = view psBlockDbEnv blockEnv
-                continueBlock logger serviceEnv dbEnv blockInProgress
+    maybeRefreshedBlockInProgress <-
+        Pool.withResource (view psReadSqlPool serviceEnv) $ \sql ->
+            withTransaction sql $
+                Checkpointer.readFrom logger cid sql
+                    (_bctxParentCreationTime $ _blockInProgressBlockCtx blockInProgress)
+                    (_bctxParentRankedBlockHash $ _blockInProgressBlockCtx blockInProgress)
+                    $ Checkpointer.readPact5 "Pact 4 cannot make new blocks" $ \blockEnv _bh -> do
+                        let dbEnv = view psBlockDbEnv blockEnv
+                        continueBlock logger serviceEnv dbEnv blockInProgress
     case maybeRefreshedBlockInProgress of
         -- the block's parent was removed
         NoHistory -> logOutraced
@@ -788,19 +791,20 @@ execPreInsertCheckReq logger serviceEnv txs = do
     let requestKeys = V.map Pact.cmdToRequestKey txs
     logFunctionText logger Info $ "(pre-insert check " <> sshow requestKeys <> ")"
     fakeParentCreationTime <- Checkpointer.mkFakeParentCreationTime
-    let act sql = Checkpointer.readFromLatest logger cid sql fakeParentCreationTime $ Checkpointer.PactRead
-            { pact5Read = \blockEnv bh -> do
-                forM txs $ \tx ->
-                    fmap (either Just (\_ -> Nothing)) $ runExceptT $ do
-                        -- it's safe to use initialBlockHandle here because it's
-                        -- only used to check for duplicate pending txs in a block
-                        () <- mapExceptT liftIO
-                            $ Pact.validateParsedChainwebTx logger blockEnv tx
-                        evalStateT (attemptBuyGas blockEnv tx) bh
-            -- pessimistically, if we're catching up and not even past the Pact
-            -- 5 activation, just badlist everything as in-the-future.
-            , pact4Read = \_ -> return $ Just InsertErrorTimeInFuture <$ txs
-            }
+    let act sql = withTransaction sql $
+            Checkpointer.readFromLatest logger cid sql fakeParentCreationTime $ Checkpointer.PactRead
+                { pact5Read = \blockEnv bh -> do
+                    forM txs $ \tx ->
+                        fmap (either Just (\_ -> Nothing)) $ runExceptT $ do
+                            -- it's safe to use initialBlockHandle here because it's
+                            -- only used to check for duplicate pending txs in a block
+                            () <- mapExceptT liftIO
+                                $ Pact.validateParsedChainwebTx logger blockEnv tx
+                            evalStateT (attemptBuyGas blockEnv tx) bh
+                -- pessimistically, if we're catching up and not even past the Pact
+                -- 5 activation, just badlist everything as in-the-future.
+                , pact4Read = \_ -> return $ Just InsertErrorTimeInFuture <$ txs
+                }
     Pool.withResource (view psReadSqlPool serviceEnv) $ \sql ->
         timeoutYield timeoutLimit (act sql) >>= \case
             Just r -> do
@@ -852,7 +856,7 @@ execLookupPactTxs logger serviceEnv confDepth txs = do
     where
     depth = maybe 0 (fromIntegral . _confirmationDepth) confDepth
     cid = _chainId serviceEnv
-    go ctx = Pool.withResource (_psReadSqlPool serviceEnv) $ \sql ->
+    go ctx = Pool.withResource (_psReadSqlPool serviceEnv) $ \sql -> withTransaction sql $
         Checkpointer.readFromNthParent logger cid sql ctx depth
             -- not sure about this, disallows looking up pact txs if we haven't
             -- caught up to pact 5

src/Chainweb/Pact/PactService/Checkpointer.hs

@@ -136,24 +136,23 @@ readFromNthParent
     -> PactRead a
     -> IO (Historical a)
 readFromNthParent logger cid sql parentCreationTime n doRead = do
-    withSavepoint sql ReadFromNSavepoint $ do
-        latest <-
-            _consensusStateLatest . fromMaybe (error "readFromNthParent is illegal to call before genesis")
-            <$> getConsensusState sql
-        if genesisHeight cid + fromIntegral @Word @BlockHeight n > _syncStateHeight latest
-        then do
-            logFunctionText logger Warn $ "readFromNthParent asked to rewind beyond genesis, to "
-                <> sshow (int (_syncStateHeight latest) - int n :: Integer)
-            return NoHistory
-        else do
-            let targetHeight = _syncStateHeight latest - fromIntegral @Word @BlockHeight n
-            lookupBlockWithHeight sql targetHeight >>= \case
-                    -- this case for shallow nodes without enough history
-                    Nothing -> do
-                        logFunctionText logger Warn "readFromNthParent asked to rewind beyond known blocks"
-                        return NoHistory
-                    Just nthBlock ->
-                        readFrom logger cid sql parentCreationTime (Parent nthBlock) doRead
+    latest <-
+        _consensusStateLatest . fromMaybe (error "readFromNthParent is illegal to call before genesis")
+        <$> getConsensusState sql
+    if genesisHeight cid + fromIntegral @Word @BlockHeight n > _syncStateHeight latest
+    then do
+        logFunctionText logger Warn $ "readFromNthParent asked to rewind beyond genesis, to "
+            <> sshow (int (_syncStateHeight latest) - int n :: Integer)
+        return NoHistory
+    else do
+        let targetHeight = _syncStateHeight latest - fromIntegral @Word @BlockHeight n
+        lookupBlockWithHeight sql targetHeight >>= \case
+                -- this case for shallow nodes without enough history
+                Nothing -> do
+                    logFunctionText logger Warn "readFromNthParent asked to rewind beyond known blocks"
+                    return NoHistory
+                Just nthBlock ->
+                    readFrom logger cid sql parentCreationTime (Parent nthBlock) doRead
 
 -- read-only rewind to a target block.
 -- if that target block is missing, return Nothing.
@@ -175,7 +174,7 @@ readFrom logger cid sql parentCreationTime parent pactRead = do
             , _bctxMinerReward = blockMinerReward (childBlockHeight cid parent)
             , _bctxChainId = cid
             }
-    liftIO $ withSavepoint sql ReadFromSavepoint $ do
+    liftIO $ do
         !latestHeader <- maybe (genesisRankedParentBlockHash cid) (Parent . _syncStateRankedBlockHash . _consensusStateLatest) <$>
             ChainwebPactDb.throwOnDbError (ChainwebPactDb.getConsensusState sql)
         -- is the parent the latest header, i.e., can we get away without rewinding?
@@ -228,8 +227,7 @@ rewindTo
     -> Parent RankedBlockHash
     -> IO ()
 rewindTo cid sql ancestor = do
-    withSavepoint sql RewindSavePoint $
-        void $ PactDb.rewindDbTo cid sql ancestor
+    void $ PactDb.rewindDbTo cid sql ancestor
 
 data PactRead a
     = PactRead
@@ -283,11 +281,10 @@ restoreAndSave
     -> NonEmpty (RunnableBlock m q)
     -> m q
 restoreAndSave logger cid sql parent blocks = do
-    withSavepoint sql RestoreAndSaveSavePoint $ do
-        -- TODO PP: check first if we're rewinding past "final" point? same with rewindTo above.
-        startTxId <- liftIO $ PactDb.rewindDbTo cid sql parent
-        let startBlockHeight = childBlockHeight cid parent
-        foldState1 (fmap executeBlock blocks) (T2 startBlockHeight startTxId)
+    -- TODO PP: check first if we're rewinding past "final" point? same with rewindTo above.
+    startTxId <- liftIO $ PactDb.rewindDbTo cid sql parent
+    let startBlockHeight = childBlockHeight cid parent
+    foldState1 (fmap executeBlock blocks) (T2 startBlockHeight startTxId)
     where
 
     executeBlock :: RunnableBlock m q -> T2 BlockHeight Pact.TxId -> m (q, T2 BlockHeight Pact.TxId)