|
| 1 | +{-# LANGUAGE BangPatterns #-} |
| 2 | +{-# LANGUAGE DataKinds #-} |
| 3 | +{-# LANGUAGE FlexibleContexts #-} |
| 4 | +{-# LANGUAGE ImportQualifiedPost #-} |
| 5 | +{-# LANGUAGE LambdaCase #-} |
| 6 | +{-# LANGUAGE NumericUnderscores #-} |
| 7 | +{-# LANGUAGE OverloadedStrings #-} |
| 8 | +{-# LANGUAGE PackageImports #-} |
| 9 | +{-# LANGUAGE RankNTypes #-} |
| 10 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 11 | +{-# LANGUAGE TypeApplications #-} |
| 12 | + |
| 13 | +module Chainweb.Test.PayloadProvider.StartupTest |
| 14 | + ( tests |
| 15 | + ) where |
| 16 | + |
| 17 | +import Chainweb.ChainId |
| 18 | +import Chainweb.Graph (singletonChainGraph) |
| 19 | +import Chainweb.Logger |
| 20 | +import Chainweb.Pact.Backend.ChainwebPactDb qualified as ChainwebPactDb |
| 21 | +import Chainweb.Pact.Backend.Types |
| 22 | +import Chainweb.Pact.PactService |
| 23 | +import Chainweb.Pact.Payload.PayloadStore.InMemory |
| 24 | +import Chainweb.Pact.Types |
| 25 | +import Chainweb.Test.Pact.Utils |
| 26 | +import Chainweb.Test.TestVersions |
| 27 | +import Chainweb.Test.Utils |
| 28 | +import Chainweb.Version |
| 29 | +import Control.Exception (try, displayException) |
| 30 | +import Control.Exception.Safe (SomeException) |
| 31 | +import Control.Monad |
| 32 | +import Control.Monad.IO.Class |
| 33 | +import Control.Monad.Trans.Resource |
| 34 | +import Data.List |
| 35 | +import Data.Maybe |
| 36 | +import Data.Version (Version(..)) |
| 37 | +import Pact.Types.SQLite |
| 38 | +import Test.Tasty |
| 39 | +import Test.Tasty.HUnit |
| 40 | + |
| 41 | +tests :: TestTree |
| 42 | +tests = testGroup "PayloadProvider.Startup" |
| 43 | + [ testMinChainwebVersionValidation |
| 44 | + ] |
| 45 | + |
| 46 | +-- | Helper function for setting up tests with loggerand sqlite |
| 47 | +withStartupTestSetup |
| 48 | + :: TestName |
| 49 | + -> (GenericLogger -> SQLiteEnv -> IO ()) |
| 50 | + -> (HasVersion => GenericLogger -> SQLiteEnv -> IO ()) |
| 51 | + -> TestTree |
| 52 | +withStartupTestSetup name setup action = withResourceT (withTempChainSqlite cid) $ \sqlIO -> do |
| 53 | + testCase name $ do |
| 54 | + logger <- getTestLogger |
| 55 | + (sql, _sqlReadPool) <- sqlIO |
| 56 | + |
| 57 | + setup logger sql |
| 58 | + |
| 59 | + withVersion v $ runResourceT $ do |
| 60 | + liftIO $ action logger sql |
| 61 | + where |
| 62 | + cid = unsafeChainId 0 |
| 63 | + v = instantCpmTestVersion singletonChainGraph |
| 64 | + |
| 65 | +-- | Initialize schema for tests |
| 66 | +initStartupTestSchema :: GenericLogger -> SQLiteEnv -> IO () |
| 67 | +initStartupTestSchema _logger sql = ChainwebPactDb.initSchema sql |
| 68 | + |
| 69 | +-- | Test that the minimum chainweb version validation works correctly |
| 70 | +testMinChainwebVersionValidation :: TestTree |
| 71 | +testMinChainwebVersionValidation = withStartupTestSetup "minimum chainweb version validation" |
| 72 | + initStartupTestSchema |
| 73 | + $ \logger sql -> do |
| 74 | + -- Test with no existing version - should succeed |
| 75 | + pdb <- newPayloadDb |
| 76 | + |
| 77 | + result1 <- try @SomeException $ runResourceT $ withPactService cid Nothing mempty logger Nothing pdb pool sql cfg genesis |
| 78 | + case result1 of |
| 79 | + Left e |
| 80 | + | "PactService required at least version:" `isInfixOf` displayException e -> |
| 81 | + liftIO $ assertFailure $ "PactService should start successfully when no minimum version is set: " <> displayException e |
| 82 | + _ -> return () |
| 83 | + |
| 84 | + let version2 = Version [2, 2] [] |
| 85 | + setMinChainwebVersion sql version2 |
| 86 | + |
| 87 | + version2' <- getMinChainwebVersion sql |
| 88 | + liftIO $ assertEqual "Should return the set version" (Just version2) version2' |
| 89 | + |
| 90 | + |
| 91 | + result2 <- try @SomeException $ runResourceT $ withPactService cid Nothing mempty logger Nothing pdb pool sql cfg genesis |
| 92 | + case result2 of |
| 93 | + Left e |
| 94 | + | "PactService required at least version:" `isInfixOf` displayException e -> |
| 95 | + liftIO $ assertFailure $ "PactService should start successfully when no minimum version is set: " <> displayException e |
| 96 | + _ -> return () |
| 97 | + |
| 98 | + let version3 = Version [200, 2] [] |
| 99 | + setMinChainwebVersion sql version3 |
| 100 | + |
| 101 | + version3' <- getMinChainwebVersion sql |
| 102 | + liftIO $ assertEqual "Should return the set version" (Just version3) version3' |
| 103 | + |
| 104 | + result3 <- try @SomeException $ runResourceT $ withPactService cid Nothing mempty logger Nothing pdb pool sql cfg genesis |
| 105 | + case result3 of |
| 106 | + Left e |
| 107 | + | "PactService required at least version:" `isInfixOf` displayException e -> |
| 108 | + pure () |
| 109 | + _ -> liftIO $ assertFailure $ "PactService should not start successfully when minimum version is not reached" |
| 110 | + |
| 111 | + where |
| 112 | + cid = unsafeChainId 0 |
| 113 | + cfg = defaultPactServiceConfig |
| 114 | + genesis = GeneratingGenesis |
| 115 | + pool = error "Pool not needed for this test" |
| 116 | + |
| 117 | + |
| 118 | +-- Helper functions (copied from PactService.hs local where clause) |
| 119 | +getMinChainwebVersion :: SQLiteEnv -> IO (Maybe Version) |
| 120 | +getMinChainwebVersion sql = qry_ sql "SELECT minMajorVersion, minMinorVersion from ChainwebMeta limit 1" [RInt, RInt] >>= \case |
| 121 | + [[SInt major, SInt minor]] -> pure $ Just $ Version [fromIntegral major, fromIntegral minor] [] |
| 122 | + [] -> pure Nothing |
| 123 | + _ -> error "incorrect column types" |
| 124 | + |
| 125 | +setMinChainwebVersion :: SQLiteEnv -> Version -> IO () |
| 126 | +setMinChainwebVersion sql (Version (major:minor:_) _) = do |
| 127 | + mMinVersion <- getMinChainwebVersion sql |
| 128 | + if isJust mMinVersion |
| 129 | + then |
| 130 | + void $ qry sql |
| 131 | + "UPDATE ChainwebMeta \ |
| 132 | + \SET minMajorVersion = ?, minMinorVersion = ?" |
| 133 | + [SInt (fromIntegral major), SInt (fromIntegral minor)] [RInt] |
| 134 | + else |
| 135 | + void $ qry sql |
| 136 | + "INSERT INTO ChainwebMeta (minMajorVersion, minMinorVersion) VALUES (?, ?)" |
| 137 | + [SInt (fromIntegral major), SInt (fromIntegral minor)] [RInt] |
| 138 | +setMinChainwebVersion _ (Version _ _) = |
| 139 | + error "version formatting does not match" |
0 commit comments