pact service enforce minimal chainweb version at startup

chainweb.cabal

@@ -665,6 +665,7 @@ test-suite chainweb-tests
         Chainweb.Test.TreeDB.RemoteDB
         Chainweb.Test.Version
         Test.Chainweb.SPV.Argument
+        Chainweb.Test.PayloadProvider.StartupTest
 
         -- Data
         Data.Test.PQueue

src/Chainweb/Pact/Backend/ChainwebPactDb.hs

@@ -810,6 +810,7 @@ getConsensusState db = do
 initSchema :: SQLiteEnv -> IO ()
 initSchema sql =
     withSavepoint sql InitSchemaSavePoint $ throwOnDbError $ do
+        createChainwebMetaTable
         createConsensusStateTable
         createBlockHistoryTable
         createTableCreationTable
@@ -824,6 +825,13 @@ initSchema sql =
     create tablename = do
         createVersionedTable tablename sql
 
+    createChainwebMetaTable :: ExceptT LocatedSQ3Error IO ()
+    createChainwebMetaTable = do
+        exec_ sql
+            "CREATE TABLE IF NOT EXISTS ChainwebMeta \
+            \(minMajorVersion INTEGER NOT NULL, \
+            \ minMinorVersion INTEGER NOT NULL);"
+
     createConsensusStateTable :: ExceptT LocatedSQ3Error IO ()
     createConsensusStateTable = do
         exec_ sql

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 (withSavepoint, SavepointName (..), LocatedSQ3Error)
 import Chainweb.Pact.NoCoinbase qualified as Pact
 import Chainweb.Pact.PactService.Checkpointer qualified as Checkpointer
 import Chainweb.Pact.PactService.ExecBlock
@@ -98,6 +98,8 @@ import Data.Monoid
 import Data.Pool (Pool)
 import Data.Pool qualified as Pool
 import Data.Text qualified as Text
+import Data.Version (Version(..))
+import Paths_chainweb (version)
 import Data.Vector (Vector)
 import Data.Vector qualified as V
 import Data.Void
@@ -117,6 +119,8 @@ import System.LogLevel
 import Chainweb.Version.Guards (pact5)
 import Control.Concurrent.MVar (newMVar)
 import Chainweb.Pact.Payload.RestAPI.Client (payloadClient)
+import Pact.Types.SQLite
+
 
 withPactService
     :: (Logger logger, CanPayloadCas tbl)
@@ -141,6 +145,17 @@ withPactService cid http memPoolAccess chainwebLogger txFailuresCounter pdb read
         )
 
     liftIO $ ChainwebPactDb.initSchema readWriteSqlenv
+
+    -- Check if the SQLiteEnv requires a minimal version of chainweb to work properly
+    mMinChainwebVersion <- liftIO $ getMinChainwebVersion readWriteSqlenv
+    case mMinChainwebVersion of
+        Nothing -> pure ()
+        Just minVersion ->
+            if version >= minVersion
+                then pure ()
+                else error $ "PactService required at least version: " <> show minVersion <> ", currently at: " <> show version
+
+
     candidatePdb <- liftIO MapTable.emptyTable
     moduleInitCacheVar <- liftIO $ newMVar mempty
 
@@ -175,6 +190,13 @@ withPactService cid http memPoolAccess chainwebLogger txFailuresCounter pdb read
         _ -> liftIO $ initialPayloadState chainwebLogger pse
     return pse
 
+    where
+    getMinChainwebVersion :: SQLiteEnv -> IO (Maybe Version)
+    getMinChainwebVersion sql = qry_ sql "SELECT minMajorVersion, minMinorVersion from ChainwebMeta limit 1" [RInt, RInt] >>= \case
+        [[SInt major, SInt minor]] -> pure $ Just $ Version [fromIntegral major, fromIntegral minor] []
+        [] -> pure Nothing
+        _ -> error "getMinChainwebVersion: incorrect column types"
+
 initialPayloadState
     :: Logger logger
     => HasVersion

test/unit/Chainweb/Test/PayloadProvider/StartupTest.hs

@@ -0,0 +1,139 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Chainweb.Test.PayloadProvider.StartupTest
+    ( tests
+    ) where
+
+import Chainweb.ChainId
+import Chainweb.Graph (singletonChainGraph)
+import Chainweb.Logger
+import Chainweb.Pact.Backend.ChainwebPactDb qualified as ChainwebPactDb
+import Chainweb.Pact.Backend.Types
+import Chainweb.Pact.PactService
+import Chainweb.Pact.Payload.PayloadStore.InMemory
+import Chainweb.Pact.Types
+import Chainweb.Test.Pact.Utils
+import Chainweb.Test.TestVersions
+import Chainweb.Test.Utils
+import Chainweb.Version
+import Control.Exception (try, displayException)
+import Control.Exception.Safe (SomeException)
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource
+import Data.List
+import Data.Maybe
+import Data.Version (Version(..))
+import Pact.Types.SQLite
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "PayloadProvider.Startup"
+    [ testMinChainwebVersionValidation
+    ]
+
+-- | Helper function for setting up tests with loggerand sqlite
+withStartupTestSetup
+    :: TestName
+    -> (GenericLogger -> SQLiteEnv -> IO ())
+    -> (HasVersion => GenericLogger -> SQLiteEnv -> IO ())
+    -> TestTree
+withStartupTestSetup name setup action = withResourceT (withTempChainSqlite cid) $ \sqlIO -> do
+    testCase name $ do
+        logger <- getTestLogger
+        (sql, _sqlReadPool) <- sqlIO
+
+        setup logger sql
+
+        withVersion v $ runResourceT $ do
+            liftIO $ action logger sql
+  where
+    cid = unsafeChainId 0
+    v = instantCpmTestVersion singletonChainGraph
+
+-- | Initialize schema for tests
+initStartupTestSchema :: GenericLogger -> SQLiteEnv -> IO ()
+initStartupTestSchema _logger sql = ChainwebPactDb.initSchema sql
+
+-- | Test that the minimum chainweb version validation works correctly
+testMinChainwebVersionValidation :: TestTree
+testMinChainwebVersionValidation = withStartupTestSetup "minimum chainweb version validation"
+    initStartupTestSchema
+    $ \logger sql -> do
+        -- Test with no existing version - should succeed
+        pdb <- newPayloadDb
+
+        result1 <- try @SomeException $ runResourceT $ withPactService cid Nothing mempty logger Nothing pdb pool sql cfg genesis
+        case result1 of
+            Left e
+                | "PactService required at least version:" `isInfixOf` displayException e ->
+                    liftIO $ assertFailure $ "PactService should start successfully when no minimum version is set: " <> displayException e
+            _ -> return ()
+
+        let version2 = Version [2, 2] []
+        setMinChainwebVersion sql version2
+
+        version2' <- getMinChainwebVersion sql
+        liftIO $ assertEqual "Should return the set version" (Just version2) version2'
+
+
+        result2 <- try @SomeException $ runResourceT $ withPactService cid Nothing mempty logger Nothing pdb pool sql cfg genesis
+        case result2 of
+            Left e
+                | "PactService required at least version:" `isInfixOf` displayException e ->
+                    liftIO $ assertFailure $ "PactService should start successfully when no minimum version is set: " <> displayException e
+            _ -> return ()
+
+        let version3 = Version [200, 2] []
+        setMinChainwebVersion sql version3
+
+        version3' <- getMinChainwebVersion sql
+        liftIO $ assertEqual "Should return the set version" (Just version3) version3'
+
+        result3 <- try @SomeException $ runResourceT $ withPactService cid Nothing mempty logger Nothing pdb pool sql cfg genesis
+        case result3 of
+            Left e
+                | "PactService required at least version:" `isInfixOf` displayException e ->
+                    pure ()
+            _ ->  liftIO $ assertFailure $ "PactService should not start successfully when minimum version is not reached"
+
+  where
+    cid = unsafeChainId 0
+    cfg = defaultPactServiceConfig
+    genesis = GeneratingGenesis
+    pool = error "Pool not needed for this test"
+
+
+-- Helper functions (copied from PactService.hs local where clause)
+getMinChainwebVersion :: SQLiteEnv -> IO (Maybe Version)
+getMinChainwebVersion sql = qry_ sql "SELECT minMajorVersion, minMinorVersion from ChainwebMeta limit 1" [RInt, RInt] >>= \case
+    [[SInt major, SInt minor]] -> pure $ Just $ Version [fromIntegral major, fromIntegral minor] []
+    [] -> pure Nothing
+    _ -> error "incorrect column types"
+
+setMinChainwebVersion :: SQLiteEnv -> Version -> IO ()
+setMinChainwebVersion sql (Version (major:minor:_) _) = do
+    mMinVersion <- getMinChainwebVersion sql
+    if isJust mMinVersion
+        then
+            void $ qry sql
+                "UPDATE ChainwebMeta \
+                \SET minMajorVersion = ?, minMinorVersion = ?"
+                [SInt (fromIntegral major), SInt (fromIntegral minor)] [RInt]
+        else
+            void $ qry sql
+                "INSERT INTO ChainwebMeta (minMajorVersion, minMinorVersion) VALUES (?, ?)"
+                [SInt (fromIntegral major), SInt (fromIntegral minor)] [RInt]
+setMinChainwebVersion _ (Version _ _) =
+    error "version formatting does not match"

test/unit/ChainwebTests.hs

@@ -46,6 +46,7 @@ import Chainweb.Test.Pact4.RewardsTest qualified
 import Chainweb.Test.Pact4.SQLite qualified
 import Chainweb.Test.Pact4.TransactionTests qualified
 import Chainweb.Test.Pact4.VerifierPluginTest qualified
+import Chainweb.Test.PayloadProvider.StartupTest qualified (tests)
 import Chainweb.Test.RestAPI qualified (tests)
 import Chainweb.Test.Roundtrips qualified (tests)
 import Chainweb.Test.Sync.WebBlockHeaderStore qualified (properties)
@@ -65,6 +66,7 @@ import Test.Tasty
 import Test.Tasty.JsonReporter
 import Test.Tasty.QuickCheck
 
+
 setTestLogLevel :: LogLevel -> IO ()
 setTestLogLevel l = setEnv "CHAINWEB_TEST_LOG_LEVEL" (show l)
 
@@ -131,6 +133,7 @@ suite rdb =
         , Chainweb.Test.BlockHeader.Genesis.tests
         , Chainweb.Test.BlockHeader.Validation.tests
         , Chainweb.Test.Version.tests
+        , Chainweb.Test.PayloadProvider.StartupTest.tests
         , testProperties "Chainweb.Test.Chainweb.Utils.Paging" Chainweb.Test.Chainweb.Utils.Paging.properties
         , testProperties "Chainweb.Test.HostAddress" Chainweb.Test.HostAddress.properties
         , testProperties "Chainweb.Test.Sync.WebBlockHeaderStore" Chainweb.Test.Sync.WebBlockHeaderStore.properties